Bugfix.
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
-
--include Makefile.config
-
-VERSION=$(shell cat globals/config.ml |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=spatch
-
-SRC=flag_cocci.ml cocci.ml testing.ml test.ml main.ml
-
-
-ifeq ($(FEATURE_PYTHON),1)
-PYCMA=pycaml/pycaml.cma
-PYDIR=pycaml
-PYLIB=dllpycaml_stubs.so
-# the following is essential for Coccinelle to compile under gentoo (wierd)
-OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-else
-PYCMA=
-PYDIR=
-PYLIB=
-OPTLIBFLAGS=
-endif
-
-
-SYSLIBS=str.cma unix.cma
-LIBS=commons/commons.cma globals/globals.cma\
- ctl/ctl.cma \
- parsing_cocci/cocci_parser.cma parsing_c/parsing_c.cma \
- engine/cocciengine.cma popl09/popl.cma \
- extra/extra.cma $(PYCMA) python/coccipython.cma
-
-MAKESUBDIRS=commons globals menhirlib $(PYDIR) ctl parsing_cocci parsing_c \
- engine popl09 extra python
-INCLUDEDIRS=commons commons/ocamlextra globals menhirlib $(PYDIR) ctl \
- parsing_cocci parsing_c engine popl09 extra python
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %)
-
-OBJS= $(SRC:.ml=.cmo)
-OPTOBJS= $(SRC:.ml=.cmx)
-
-EXEC=$(TARGET)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-OCAMLCFLAGS= #-g -dtypes # -w A
-
-# for profiling add -p -inline 0
-# but 'make forprofiling' below does that for you.
-# This flag is also used in subdirectories so don't change its name here.
-OPTFLAGS=
-# the following is essential for Coccinelle to compile under gentoo
-# but is now defined above in this file
-#OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-
-# the OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN= #.opt
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-# can also be set via 'make static'
-STATIC= #-ccopt -static
-
-# can also be unset via 'make purebytecode'
-BYTECODE_STATIC=-custom
-
-##############################################################################
-# Top rules
-##############################################################################
-all: subdirs
-opt: subdirs.opt
-all.opt: opt
-top: $(EXEC).top
-
-.PHONY: $(MAKESUBDIRS) $(MAKESUBDIRS:%=%.opt)
-
-$(MAKESUBDIRS):
- $(MAKE) -C $@ OCAMLCFLAGS="$(OCAMLCFLAGS)" all
-
-$(MAKESUBDIRS:%=%.opt):
- $(MAKE) -C $(@:%.opt=%) OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt
-
-commons:
-globals:
-menhirlib:
-parsing_cocci:globals menhirlib
-parsing_c:parsing_cocci
-ctl:globals commons
-engine: parsing_cocci parsing_c ctl
-popl09:engine
-extra: parsing_cocci parsing_c ctl
-pycaml:
-python:pycaml parsing_cocci parsing_c
-
-commons.opt:
-globals.opt:
-menhirlib.opt:
-parsing_cocci.opt:globals.opt menhirlib.opt
-parsing_c.opt:parsing_cocci.opt
-ctl.opt:globals.opt commons.opt
-engine.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-popl09.opt:engine.opt
-extra.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-pycaml.opt:
-python.opt:pycaml.opt parsing_cocci.opt parsing_c.opt
-
-# set -e; for i in $(MAKESUBDIRS); \
-# do $(MAKE) -C $$i OCAMLCFLAGS="$(OCAMLCFLAGS)" all; done
-#
-#rec.opt:
-# set -e; for i in $(MAKESUBDIRS); \
-# do $(MAKE) -C $$i OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt; done
-clean::
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
-
-configure:
- ./configure
-
-$(LIBS): $(MAKESUBDIRS)
-$(LIBS:.cma=.cmxa): $(MAKESUBDIRS:%=%.opt)
-
-subdirs:
- echo "$(SRC:.ml=.cmi): $(MAKESUBDIRS)" > .subdirs
- $(MAKE) $(EXEC)
-
-subdirs.opt:
- echo "$(SRC:.ml=.cmi): $(MAKESUBDIRS:%=%.opt)" > .subdirs
- $(MAKE) $(EXEC).opt
-
--include .subdirs
-
-$(OBJS):$(LIBS)
-$(OPTOBJS):$(LIBS:.cma=.cmxa)
-
-$(EXEC): $(LIBS) $(OBJS)
- $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
-
-$(EXEC).opt: $(LIBS:.cma=.cmxa) $(OPTOBJS)
- $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $(OPTLIBFLAGS) $^
-
-$(EXEC).top: $(LIBS) $(OBJS)
- $(OCAMLMKTOP) -custom -o $@ $(SYSLIBS) $^
-
-clean::
- rm -f $(TARGET) $(TARGET).opt $(TARGET).top
-
-clean::
- rm -f dllpycaml_stubs.so
-
-
-.PHONY: tools all configure
-
-tools:
- $(MAKE) -C tools
-clean::
- $(MAKE) -C tools clean
-
-
-static:
- rm -f spatch.opt spatch
- $(MAKE) STATIC="-ccopt -static" spatch.opt
- cp spatch.opt spatch
-
-purebytecode:
- rm -f spatch.opt spatch
- $(MAKE) BYTECODE_STATIC="" spatch
-
-
-##############################################################################
-# Install
-##############################################################################
-
-# don't remove DESTDIR, it can be set by package build system like ebuild
-install: all
- mkdir -p $(DESTDIR)$(BINDIR)
- mkdir -p $(DESTDIR)$(LIBDIR)
- mkdir -p $(DESTDIR)$(SHAREDIR)
- mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp spatch $(DESTDIR)$(BINDIR)
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
- @echo ""
- @echo "You can also install spatch by copying the program spatch"
- @echo "(available in this directory) anywhere you want and"
- @echo "give it the right options to find its configuration files."
-
-uninstall:
- rm -f $(DESTDIR)$(BINDIR)/spatch
- rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
- rm -f $(DESTDIR)$(SHAREDIR)/standard.h
- rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
- rm -rf $(DESTDIR)$(SHAREDIR)/python/coccilib
- rm -f $(DESTDIR)$(MANDIR)/man1/spatch.1
-
-
-
-version:
- @echo $(VERSION)
-
-
-##############################################################################
-# Package rules
-##############################################################################
-
-PACKAGE=coccinelle-$(VERSION)
-
-BINSRC=spatch env.sh env.csh standard.h standard.iso \
- *.txt docs/* \
- demos/foo.* demos/simple.*
-# $(PYLIB) python/coccilib/ demos/printloc.*
-BINSRC2=$(BINSRC:%=$(PACKAGE)/%)
-
-TMP=/tmp
-OCAMLVERSION=$(shell ocaml -version |perl -p -e 's/.*version (.*)/$$1/;')
-
-# Procedure to do first time:
-# cd ~/release
-# cvs checkout coccinelle
-# cd coccinelle
-# cvs update -d -P
-# touch **/*
-# make licensify
-# remember to comment the -g -dtypes in this Makefile
-
-# Procedure to do each time:
-# cvs update
-# ./configure --without-python
-# make package
-# make website
-# Check also that run an ocaml in /usr/bin
-
-# To test you can try compile and run spatch from different instances
-# like my ~/coccinelle, ~/release/coccinelle, and the /tmp/coccinelle-0.X
-# downloaded from the website.
-
-# For 'make srctar' it must done from a clean
-# repo such as ~/release/coccinelle. It must also be a repo where
-# the scripts/licensify has been run at least once.
-# For the 'make bintar' I can do it from my original repo.
-
-
-package:
- make srctar
- make bintar
- make staticbintar
- make bytecodetar
-
-# I currently pre-generate the parser so the user does not have to
-# install menhir on his machine. I also do a few cleanups like 'rm todo_pos'.
-# You may have first to do a 'make licensify'.
-srctar:
- make clean
- cp -a . $(TMP)/$(PACKAGE)
- cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
- cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude=CVS $(PACKAGE)
- rm -rf $(TMP)/$(PACKAGE)
-
-
-bintar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86.tgz --exclude=CVS $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-staticbintar: all.opt
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make static
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86-static.tgz --exclude=CVS $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-# add ocaml version in name ?
-bytecodetar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make purebytecode
- cd $(TMP); tar cvfz $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz --exclude=CVS $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-clean::
- rm -f $(PACKAGE)
- rm -f $(PACKAGE)-bin-x86.tgz
- rm -f $(PACKAGE)-bin-x86-static.tgz
- rm -f $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz
-
-
-
-TOLICENSIFY=ctl engine parsing_cocci popl popl09 python
-licensify:
- ocaml tools/licensify.ml
- set -e; for i in $(TOLICENSIFY); do cd $$i; ocaml ../tools/licensify.ml; cd ..; done
-
-# When checking out the source from diku sometimes I have some "X in the future"
-# error messages.
-fixdates:
- echo do 'touch **/*.*'
-
-#fixCVS:
-# cvs update -d -P
-# echo do 'rm -rf **/CVS'
-
-ocamlversion:
- @echo $(OCAMLVERSION)
-
-
-##############################################################################
-# Pad specific rules
-##############################################################################
-
-#TOP=/home/pad/mobile/project-coccinelle
-WEBSITE=/home/pad/mobile/homepage/software/project-coccinelle
-
-website:
- cp $(TMP)/$(PACKAGE).tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86-static.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz $(WEBSITE)
-
-
-#TXT=$(wildcard *.txt)
-syncwiki:
-# unison ~/public_html/wiki/wiki-LFS/data/pages/ docs/wiki/
-# set -e; for i in $(TXT); do unison $$i docs/wiki/$$i; done
-
-darcsweb:
-# @echo pull from ~/public_html/darcs/c-coccinelle and c-commons and lib-xxx
-
-DARCSFORESTS=commons \
- parsing_c parsing_cocci engine
-
-update_darcs:
- darcs pull
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs pull; cd ..; done
-
-#darcs diff -u
-diff_darcs:
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs diff -u; cd ..; done
-
-
-##############################################################################
-# Developer rules
-##############################################################################
-
-test: $(TARGET)
- ./$(TARGET) -testall
-
-testparsing:
- ./$(TARGET) -D standard.h -parse_c -dir tests/
-
-
-
-# -inline 0 to see all the functions in the profile.
-# Can also use the profile framework in commons/ and run your program
-# with -profile.
-forprofiling:
- $(MAKE) OPTFLAGS="-p -inline 0 " opt
-
-clean::
- rm -f gmon.out
-
-tags:
- otags -no-mli-tags -r .
-
-dependencygraph:
- find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl09 -I extra > /tmp/dependfull.depend
- ocamldot -lr /tmp/dependfull.depend > /tmp/dependfull.dot
- dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
- ps2pdf /tmp/dependfull.ps /tmp/dependfull.pdf
-
-##############################################################################
-# Misc rules
-##############################################################################
-
-# each member of the project can have its own test.ml. this file is
-# not under CVS.
-test.ml:
- echo "let foo_ctl () = failwith \"there is no foo_ctl formula\"" \
- > test.ml
-
-beforedepend:: test.ml
-
-
-#INC=$(dir $(shell which ocaml))
-#INCX=$(INC:/=)
-#INCY=$(dir $(INCX))
-#INCZ=$(INCY:/=)/lib/ocaml
-#
-#prim.o: prim.c
-# gcc -c -o prim.o -I $(INCZ) prim.c
-
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[iox] *.o *.annot
-
-clean::
- rm -f *~ .*~ *.exe #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i depend; done
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
-
--include Makefile.config
-
-VERSION=$(shell cat globals/config.ml |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=spatch
-
-SRC=flag_cocci.ml cocci.ml testing.ml test.ml main.ml
-
-
-ifeq ($(FEATURE_PYTHON),1)
-PYCMA=pycaml/pycaml.cma
-PYDIR=pycaml
-PYLIB=dllpycaml_stubs.so
-# the following is essential for Coccinelle to compile under gentoo (wierd)
-OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-else
-PYCMA=
-PYDIR=
-PYLIB=
-OPTLIBFLAGS=
-endif
-
-
-SYSLIBS=str.cma unix.cma
-LIBS=commons/commons.cma globals/globals.cma\
- ctl/ctl.cma \
- parsing_cocci/cocci_parser.cma parsing_c/parsing_c.cma \
- engine/cocciengine.cma popl09/popl.cma \
- extra/extra.cma $(PYCMA) python/coccipython.cma
-
-MAKESUBDIRS=commons globals menhirlib $(PYDIR) ctl parsing_cocci parsing_c \
- engine popl09 extra python
-INCLUDEDIRS=commons commons/ocamlextra globals menhirlib $(PYDIR) ctl \
- parsing_cocci parsing_c engine popl09 extra python
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %)
-
-OBJS= $(SRC:.ml=.cmo)
-OPTOBJS= $(SRC:.ml=.cmx)
-
-EXEC=$(TARGET)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-OCAMLCFLAGS= #-g -dtypes # -w A
-
-# for profiling add -p -inline 0
-# but 'make forprofiling' below does that for you.
-# This flag is also used in subdirectories so don't change its name here.
-OPTFLAGS=
-# the following is essential for Coccinelle to compile under gentoo
-# but is now defined above in this file
-#OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-
-# the OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN= #.opt
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-# can also be set via 'make static'
-STATIC= #-ccopt -static
-
-# can also be unset via 'make purebytecode'
-BYTECODE_STATIC=-custom
-
-##############################################################################
-# Top rules
-##############################################################################
-.PHONY: all all.opt opt top clean configure
-.PHONY: $(MAKESUBDIRS) $(MAKESUBDIRS:%=%.opt)
-
-all:
- $(MAKE) subdirs
- $(MAKE) $(EXEC)
-
-opt:
- $(MAKE) subdirs.opt
- $(MAKE) $(EXEC).opt
-
-all.opt: opt
-top: $(EXEC).top
-
-subdirs: $(MAKESUBDIRS)
-subdirs.opt: $(MAKESUBDIRS:%=%.opt)
-
-$(MAKESUBDIRS):
- $(MAKE) -C $@ OCAMLCFLAGS="$(OCAMLCFLAGS)" all
-
-$(MAKESUBDIRS:%=%.opt):
- $(MAKE) -C $(@:%.opt=%) OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt
-
-commons:
-globals:
-menhirlib:
-parsing_cocci:globals menhirlib
-parsing_c:parsing_cocci
-ctl:globals commons
-engine: parsing_cocci parsing_c ctl
-popl09:engine
-extra: parsing_cocci parsing_c ctl
-pycaml:
-python:pycaml parsing_cocci parsing_c
-
-commons.opt:
-globals.opt:
-menhirlib.opt:
-parsing_cocci.opt:globals.opt menhirlib.opt
-parsing_c.opt:parsing_cocci.opt
-ctl.opt:globals.opt commons.opt
-engine.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-popl09.opt:engine.opt
-extra.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-pycaml.opt:
-python.opt:pycaml.opt parsing_cocci.opt parsing_c.opt
-
-clean::
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
-
-configure:
- ./configure
-
-$(LIBS): #$(MAKESUBDIRS)
-$(LIBS:.cma=.cmxa): #$(MAKESUBDIRS:%=%.opt)
-
-$(OBJS):$(LIBS)
-$(OPTOBJS):$(LIBS:.cma=.cmxa)
-
-$(EXEC): $(LIBS) $(OBJS)
- $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
-
-$(EXEC).opt: $(LIBS:.cma=.cmxa) $(OPTOBJS)
- $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $(OPTLIBFLAGS) $^
-
-$(EXEC).top: $(LIBS) $(OBJS)
- $(OCAMLMKTOP) -custom -o $@ $(SYSLIBS) $^
-
-clean::
- rm -f $(TARGET) $(TARGET).opt $(TARGET).top
-
-clean::
- rm -f dllpycaml_stubs.so
-
-
-.PHONY: tools all configure
-
-tools:
- $(MAKE) -C tools
-clean::
- $(MAKE) -C tools clean
-
-
-static:
- rm -f spatch.opt spatch
- $(MAKE) STATIC="-ccopt -static" spatch.opt
- cp spatch.opt spatch
-
-purebytecode:
- rm -f spatch.opt spatch
- $(MAKE) BYTECODE_STATIC="" spatch
-
-
-##############################################################################
-# Install
-##############################################################################
-
-# don't remove DESTDIR, it can be set by package build system like ebuild
-install: all
- mkdir -p $(DESTDIR)$(BINDIR)
- mkdir -p $(DESTDIR)$(LIBDIR)
- mkdir -p $(DESTDIR)$(SHAREDIR)
- mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp spatch $(DESTDIR)$(BINDIR)
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
- @echo ""
- @echo "You can also install spatch by copying the program spatch"
- @echo "(available in this directory) anywhere you want and"
- @echo "give it the right options to find its configuration files."
-
-uninstall:
- rm -f $(DESTDIR)$(BINDIR)/spatch
- rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
- rm -f $(DESTDIR)$(SHAREDIR)/standard.h
- rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
- rm -rf $(DESTDIR)$(SHAREDIR)/python/coccilib
- rm -f $(DESTDIR)$(MANDIR)/man1/spatch.1
-
-
-
-version:
- @echo $(VERSION)
-
-
-##############################################################################
-# Package rules
-##############################################################################
-
-PACKAGE=coccinelle-$(VERSION)
-
-BINSRC=spatch env.sh env.csh standard.h standard.iso \
- *.txt docs/* \
- demos/foo.* demos/simple.*
-# $(PYLIB) python/coccilib/ demos/printloc.*
-BINSRC2=$(BINSRC:%=$(PACKAGE)/%)
-
-TMP=/tmp
-OCAMLVERSION=$(shell ocaml -version |perl -p -e 's/.*version (.*)/$$1/;')
-
-# Procedure to do first time:
-# cd ~/release
-# cvs checkout coccinelle
-# cd coccinelle
-# cvs update -d -P
-# touch **/*
-# make licensify
-# remember to comment the -g -dtypes in this Makefile
-
-# Procedure to do each time:
-# cvs update
-# modify globals/config.ml
-# cd globals/; cvs commit -m"new version" (do not commit from the root!)
-# ./configure --without-python
-# make package
-# make website
-# Check also that run an ocaml in /usr/bin
-
-# To test you can try compile and run spatch from different instances
-# like my ~/coccinelle, ~/release/coccinelle, and the /tmp/coccinelle-0.X
-# downloaded from the website.
-
-# For 'make srctar' it must done from a clean
-# repo such as ~/release/coccinelle. It must also be a repo where
-# the scripts/licensify has been run at least once.
-# For the 'make bintar' I can do it from my original repo.
-
-
-package:
- make srctar
- make bintar
- make staticbintar
- make bytecodetar
-
-# I currently pre-generate the parser so the user does not have to
-# install menhir on his machine. I also do a few cleanups like 'rm todo_pos'.
-# You may have first to do a 'make licensify'.
-srctar:
- make clean
- cp -a . $(TMP)/$(PACKAGE)
- cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
- cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE)
- rm -rf $(TMP)/$(PACKAGE)
-
-
-bintar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-staticbintar: all.opt
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make static
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86-static.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-# add ocaml version in name ?
-bytecodetar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make purebytecode
- cd $(TMP); tar cvfz $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-clean::
- rm -f $(PACKAGE)
- rm -f $(PACKAGE)-bin-x86.tgz
- rm -f $(PACKAGE)-bin-x86-static.tgz
- rm -f $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz
-
-
-
-TOLICENSIFY=ctl engine parsing_cocci popl popl09 python
-licensify:
- ocaml tools/licensify.ml
- set -e; for i in $(TOLICENSIFY); do cd $$i; ocaml ../tools/licensify.ml; cd ..; done
-
-# When checking out the source from diku sometimes I have some "X in the future"
-# error messages.
-fixdates:
- echo do 'touch **/*.*'
-
-#fixCVS:
-# cvs update -d -P
-# echo do 'rm -rf **/CVS'
-
-ocamlversion:
- @echo $(OCAMLVERSION)
-
-
-##############################################################################
-# Pad specific rules
-##############################################################################
-
-#TOP=/home/pad/mobile/project-coccinelle
-WEBSITE=/home/pad/mobile/homepage/software/project-coccinelle
-
-website:
- cp $(TMP)/$(PACKAGE).tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86-static.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz $(WEBSITE)
-
-
-#TXT=$(wildcard *.txt)
-syncwiki:
-# unison ~/public_html/wiki/wiki-LFS/data/pages/ docs/wiki/
-# set -e; for i in $(TXT); do unison $$i docs/wiki/$$i; done
-
-darcsweb:
-# @echo pull from ~/public_html/darcs/c-coccinelle and c-commons and lib-xxx
-
-DARCSFORESTS=commons \
- parsing_c parsing_cocci engine
-
-update_darcs:
- darcs pull
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs pull; cd ..; done
-
-#darcs diff -u
-diff_darcs:
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs diff -u; cd ..; done
-
-
-##############################################################################
-# Developer rules
-##############################################################################
-
-test: $(TARGET)
- ./$(TARGET) -testall
-
-testparsing:
- ./$(TARGET) -D standard.h -parse_c -dir tests/
-
-
-
-# -inline 0 to see all the functions in the profile.
-# Can also use the profile framework in commons/ and run your program
-# with -profile.
-forprofiling:
- $(MAKE) OPTFLAGS="-p -inline 0 " opt
-
-clean::
- rm -f gmon.out
-
-tags:
- otags -no-mli-tags -r .
-
-dependencygraph:
- find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl09 -I extra > /tmp/dependfull.depend
- ocamldot -lr /tmp/dependfull.depend > /tmp/dependfull.dot
- dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
- ps2pdf /tmp/dependfull.ps /tmp/dependfull.pdf
-
-##############################################################################
-# Misc rules
-##############################################################################
-
-# each member of the project can have its own test.ml. this file is
-# not under CVS.
-test.ml:
- echo "let foo_ctl () = failwith \"there is no foo_ctl formula\"" \
- > test.ml
-
-beforedepend:: test.ml
-
-
-#INC=$(dir $(shell which ocaml))
-#INCX=$(INC:/=)
-#INCY=$(dir $(INCX))
-#INCZ=$(INCY:/=)/lib/ocaml
-#
-#prim.o: prim.c
-# gcc -c -o prim.o -I $(INCZ) prim.c
-
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[iox] *.o *.annot
-
-clean::
- rm -f *~ .*~ *.exe #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i depend; done
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
-
--include Makefile.config
-
-VERSION=$(shell cat globals/config.ml |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=spatch
-
-SRC=flag_cocci.ml cocci.ml testing.ml test.ml main.ml
-
-
-ifeq ($(FEATURE_PYTHON),1)
-PYCMA=pycaml/pycaml.cma
-PYDIR=pycaml
-PYLIB=dllpycaml_stubs.so
-# the following is essential for Coccinelle to compile under gentoo (wierd)
-OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-else
-PYCMA=
-PYDIR=
-PYLIB=
-OPTLIBFLAGS=
-endif
-
-
-SYSLIBS=str.cma unix.cma
-LIBS=commons/commons.cma globals/globals.cma\
- ctl/ctl.cma \
- parsing_cocci/cocci_parser.cma parsing_c/parsing_c.cma \
- engine/cocciengine.cma popl09/popl.cma \
- extra/extra.cma $(PYCMA) python/coccipython.cma
-
-MAKESUBDIRS=commons globals menhirlib $(PYDIR) ctl parsing_cocci parsing_c \
- engine popl09 extra python
-INCLUDEDIRS=commons commons/ocamlextra globals menhirlib $(PYDIR) ctl \
- parsing_cocci parsing_c engine popl09 extra python
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %)
-
-OBJS= $(SRC:.ml=.cmo)
-OPTOBJS= $(SRC:.ml=.cmx)
-
-EXEC=$(TARGET)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-OCAMLCFLAGS= #-g -dtypes # -w A
-
-# for profiling add -p -inline 0
-# but 'make forprofiling' below does that for you.
-# This flag is also used in subdirectories so don't change its name here.
-OPTFLAGS=
-# the following is essential for Coccinelle to compile under gentoo
-# but is now defined above in this file
-#OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-
-# the OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN= #.opt
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-# can also be set via 'make static'
-STATIC= #-ccopt -static
-
-# can also be unset via 'make purebytecode'
-BYTECODE_STATIC=-custom
-
-##############################################################################
-# Top rules
-##############################################################################
-.PHONY: all all.opt opt top clean configure
-.PHONY: $(MAKESUBDIRS) $(MAKESUBDIRS:%=%.opt)
-
-all:
- $(MAKE) subdirs
- $(MAKE) $(EXEC)
-
-opt:
- $(MAKE) subdirs.opt
- $(MAKE) $(EXEC).opt
-
-all.opt: opt
-top: $(EXEC).top
-
-subdirs: $(MAKESUBDIRS)
-subdirs.opt: $(MAKESUBDIRS:%=%.opt)
-
-$(MAKESUBDIRS):
- $(MAKE) -C $@ OCAMLCFLAGS="$(OCAMLCFLAGS)" all
-
-$(MAKESUBDIRS:%=%.opt):
- $(MAKE) -C $(@:%.opt=%) OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt
-
-commons:
-globals:
-menhirlib:
-parsing_cocci:globals menhirlib
-parsing_c:parsing_cocci
-ctl:globals commons
-engine: parsing_cocci parsing_c ctl
-popl09:engine
-extra: parsing_cocci parsing_c ctl
-pycaml:
-python:pycaml parsing_cocci parsing_c
-
-commons.opt:
-globals.opt:
-menhirlib.opt:
-parsing_cocci.opt:globals.opt menhirlib.opt
-parsing_c.opt:parsing_cocci.opt
-ctl.opt:globals.opt commons.opt
-engine.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-popl09.opt:engine.opt
-extra.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-pycaml.opt:
-python.opt:pycaml.opt parsing_cocci.opt parsing_c.opt
-
-clean::
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
-
-configure:
- ./configure
-
-$(LIBS): #$(MAKESUBDIRS)
-$(LIBS:.cma=.cmxa): #$(MAKESUBDIRS:%=%.opt)
-
-$(OBJS):$(LIBS)
-$(OPTOBJS):$(LIBS:.cma=.cmxa)
-
-$(EXEC): $(LIBS) $(OBJS)
- $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
-
-$(EXEC).opt: $(LIBS:.cma=.cmxa) $(OPTOBJS)
- $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $(OPTLIBFLAGS) $^
-
-$(EXEC).top: $(LIBS) $(OBJS)
- $(OCAMLMKTOP) -custom -o $@ $(SYSLIBS) $^
-
-clean::
- rm -f $(TARGET) $(TARGET).opt $(TARGET).top
-
-clean::
- rm -f dllpycaml_stubs.so
-
-
-.PHONY: tools all configure
-
-tools:
- $(MAKE) -C tools
-clean::
- $(MAKE) -C tools clean
-
-
-static:
- rm -f spatch.opt spatch
- $(MAKE) STATIC="-ccopt -static" spatch.opt
- cp spatch.opt spatch
-
-purebytecode:
- rm -f spatch.opt spatch
- $(MAKE) BYTECODE_STATIC="" spatch
-
-
-##############################################################################
-# Install
-##############################################################################
-
-# don't remove DESTDIR, it can be set by package build system like ebuild
-install: all
- mkdir -p $(DESTDIR)$(BINDIR)
- mkdir -p $(DESTDIR)$(LIBDIR)
- mkdir -p $(DESTDIR)$(SHAREDIR)
- mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp spatch $(DESTDIR)$(BINDIR)
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
- @echo ""
- @echo "You can also install spatch by copying the program spatch"
- @echo "(available in this directory) anywhere you want and"
- @echo "give it the right options to find its configuration files."
-
-uninstall:
- rm -f $(DESTDIR)$(BINDIR)/spatch
- rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
- rm -f $(DESTDIR)$(SHAREDIR)/standard.h
- rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
- rm -rf $(DESTDIR)$(SHAREDIR)/python/coccilib
- rm -f $(DESTDIR)$(MANDIR)/man1/spatch.1
-
-
-
-version:
- @echo $(VERSION)
-
-
-##############################################################################
-# Package rules
-##############################################################################
-
-PACKAGE=coccinelle-$(VERSION)
-
-BINSRC=spatch env.sh env.csh standard.h standard.iso \
- *.txt docs/* \
- demos/foo.* demos/simple.*
-# $(PYLIB) python/coccilib/ demos/printloc.*
-BINSRC2=$(BINSRC:%=$(PACKAGE)/%)
-
-TMP=/tmp
-OCAMLVERSION=$(shell ocaml -version |perl -p -e 's/.*version (.*)/$$1/;')
-
-# Procedure to do first time:
-# cd ~/release
-# cvs checkout coccinelle
-# cd coccinelle
-# cvs update -d -P
-# touch **/*
-# make licensify
-# remember to comment the -g -dtypes in this Makefile
-
-# Procedure to do each time:
-# cvs update
-# make sure that ocaml is the distribution ocaml of /usr/bin, not ~pad/...
-# modify globals/config.ml
-# cd globals/; cvs commit -m"new version" (do not commit from the root!)
-# ./configure --without-python
-# make package
-# make website
-# Check that run an ocaml in /usr/bin
-
-# To test you can try compile and run spatch from different instances
-# like my ~/coccinelle, ~/release/coccinelle, and the /tmp/coccinelle-0.X
-# downloaded from the website.
-
-# For 'make srctar' it must done from a clean
-# repo such as ~/release/coccinelle. It must also be a repo where
-# the scripts/licensify has been run at least once.
-# For the 'make bintar' I can do it from my original repo.
-
-
-package:
- make srctar
- make bintar
- make staticbintar
- make bytecodetar
-
-# I currently pre-generate the parser so the user does not have to
-# install menhir on his machine. I also do a few cleanups like 'rm todo_pos'.
-# You may have first to do a 'make licensify'.
-srctar:
- make clean
- cp -a . $(TMP)/$(PACKAGE)
- cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
- cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE)
- rm -rf $(TMP)/$(PACKAGE)
-
-
-bintar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-staticbintar: all.opt
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make static
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86-static.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-# add ocaml version in name ?
-bytecodetar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make purebytecode
- cd $(TMP); tar cvfz $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-clean::
- rm -f $(PACKAGE)
- rm -f $(PACKAGE)-bin-x86.tgz
- rm -f $(PACKAGE)-bin-x86-static.tgz
- rm -f $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz
-
-
-
-TOLICENSIFY=ctl engine parsing_cocci popl popl09 python
-licensify:
- ocaml tools/licensify.ml
- set -e; for i in $(TOLICENSIFY); do cd $$i; ocaml ../tools/licensify.ml; cd ..; done
-
-# When checking out the source from diku sometimes I have some "X in the future"
-# error messages.
-fixdates:
- echo do 'touch **/*.*'
-
-#fixCVS:
-# cvs update -d -P
-# echo do 'rm -rf **/CVS'
-
-ocamlversion:
- @echo $(OCAMLVERSION)
-
-
-##############################################################################
-# Pad specific rules
-##############################################################################
-
-#TOP=/home/pad/mobile/project-coccinelle
-WEBSITE=/home/pad/mobile/homepage/software/project-coccinelle
-
-website:
- cp $(TMP)/$(PACKAGE).tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86-static.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz $(WEBSITE)
-
-
-#TXT=$(wildcard *.txt)
-syncwiki:
-# unison ~/public_html/wiki/wiki-LFS/data/pages/ docs/wiki/
-# set -e; for i in $(TXT); do unison $$i docs/wiki/$$i; done
-
-darcsweb:
-# @echo pull from ~/public_html/darcs/c-coccinelle and c-commons and lib-xxx
-
-DARCSFORESTS=commons \
- parsing_c parsing_cocci engine
-
-update_darcs:
- darcs pull
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs pull; cd ..; done
-
-#darcs diff -u
-diff_darcs:
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs diff -u; cd ..; done
-
-
-##############################################################################
-# Developer rules
-##############################################################################
-
-test: $(TARGET)
- ./$(TARGET) -testall
-
-testparsing:
- ./$(TARGET) -D standard.h -parse_c -dir tests/
-
-
-
-# -inline 0 to see all the functions in the profile.
-# Can also use the profile framework in commons/ and run your program
-# with -profile.
-forprofiling:
- $(MAKE) OPTFLAGS="-p -inline 0 " opt
-
-clean::
- rm -f gmon.out
-
-tags:
- otags -no-mli-tags -r .
-
-dependencygraph:
- find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl09 -I extra > /tmp/dependfull.depend
- ocamldot -lr /tmp/dependfull.depend > /tmp/dependfull.dot
- dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
- ps2pdf /tmp/dependfull.ps /tmp/dependfull.pdf
-
-##############################################################################
-# Misc rules
-##############################################################################
-
-# each member of the project can have its own test.ml. this file is
-# not under CVS.
-test.ml:
- echo "let foo_ctl () = failwith \"there is no foo_ctl formula\"" \
- > test.ml
-
-beforedepend:: test.ml
-
-
-#INC=$(dir $(shell which ocaml))
-#INCX=$(INC:/=)
-#INCY=$(dir $(INCX))
-#INCZ=$(INCY:/=)/lib/ocaml
-#
-#prim.o: prim.c
-# gcc -c -o prim.o -I $(INCZ) prim.c
-
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[iox] *.o *.annot
-
-clean::
- rm -f *~ .*~ *.exe #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i depend; done
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
-
--include Makefile.config
-
-VERSION=$(shell cat globals/config.ml |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=spatch
-
-SRC=flag_cocci.ml cocci.ml testing.ml test.ml main.ml
-
-
-ifeq ($(FEATURE_PYTHON),1)
-PYCMA=pycaml/pycaml.cma
-PYDIR=pycaml
-PYLIB=dllpycaml_stubs.so
-# the following is essential for Coccinelle to compile under gentoo (wierd)
-OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-else
-PYCMA=
-PYDIR=
-PYLIB=
-OPTLIBFLAGS=
-endif
-
-
-SYSLIBS=str.cma unix.cma
-LIBS=commons/commons.cma globals/globals.cma\
- ctl/ctl.cma \
- parsing_cocci/cocci_parser.cma parsing_c/parsing_c.cma \
- engine/cocciengine.cma popl09/popl.cma \
- extra/extra.cma $(PYCMA) python/coccipython.cma
-
-MAKESUBDIRS=commons globals menhirlib $(PYDIR) ctl parsing_cocci parsing_c \
- engine popl09 extra python
-INCLUDEDIRS=commons commons/ocamlextra globals menhirlib $(PYDIR) ctl \
- parsing_cocci parsing_c engine popl09 extra python
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %)
-
-OBJS= $(SRC:.ml=.cmo)
-OPTOBJS= $(SRC:.ml=.cmx)
-
-EXEC=$(TARGET)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-OCAMLCFLAGS= #-g -dtypes # -w A
-
-# for profiling add -p -inline 0
-# but 'make forprofiling' below does that for you.
-# This flag is also used in subdirectories so don't change its name here.
-OPTFLAGS=
-# the following is essential for Coccinelle to compile under gentoo
-# but is now defined above in this file
-#OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-
-# the OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN= #.opt
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-# can also be set via 'make static'
-STATIC= #-ccopt -static
-
-# can also be unset via 'make purebytecode'
-BYTECODE_STATIC=-custom
-
-##############################################################################
-# Top rules
-##############################################################################
-.PHONY: all all.opt opt top clean configure
-.PHONY: $(MAKESUBDIRS) $(MAKESUBDIRS:%=%.opt)
-
-all:
- $(MAKE) subdirs
- $(MAKE) $(EXEC)
-
-opt:
- $(MAKE) subdirs.opt
- $(MAKE) $(EXEC).opt
-
-all.opt: opt
-top: $(EXEC).top
-
-subdirs: $(MAKESUBDIRS)
-subdirs.opt: $(MAKESUBDIRS:%=%.opt)
-
-$(MAKESUBDIRS):
- $(MAKE) -C $@ OCAMLCFLAGS="$(OCAMLCFLAGS)" all
-
-$(MAKESUBDIRS:%=%.opt):
- $(MAKE) -C $(@:%.opt=%) OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt
-
-commons:
-globals:
-menhirlib:
-parsing_cocci:globals menhirlib
-parsing_c:parsing_cocci
-ctl:globals commons
-engine: parsing_cocci parsing_c ctl
-popl09:engine
-extra: parsing_cocci parsing_c ctl
-pycaml:
-python:pycaml parsing_cocci parsing_c
-
-commons.opt:
-globals.opt:
-menhirlib.opt:
-parsing_cocci.opt:globals.opt menhirlib.opt
-parsing_c.opt:parsing_cocci.opt
-ctl.opt:globals.opt commons.opt
-engine.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-popl09.opt:engine.opt
-extra.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-pycaml.opt:
-python.opt:pycaml.opt parsing_cocci.opt parsing_c.opt
-
-clean::
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
-
-configure:
- ./configure
-
-$(LIBS): #$(MAKESUBDIRS)
-$(LIBS:.cma=.cmxa): #$(MAKESUBDIRS:%=%.opt)
-
-$(OBJS):$(LIBS)
-$(OPTOBJS):$(LIBS:.cma=.cmxa)
-
-$(EXEC): $(LIBS) $(OBJS)
- $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
-
-$(EXEC).opt: $(LIBS:.cma=.cmxa) $(OPTOBJS)
- $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $(OPTLIBFLAGS) $^
-
-$(EXEC).top: $(LIBS) $(OBJS)
- $(OCAMLMKTOP) -custom -o $@ $(SYSLIBS) $^
-
-clean::
- rm -f $(TARGET) $(TARGET).opt $(TARGET).top
-
-clean::
- rm -f dllpycaml_stubs.so
-
-
-.PHONY: tools all configure
-
-tools:
- $(MAKE) -C tools
-clean::
- $(MAKE) -C tools clean
-
-
-static:
- rm -f spatch.opt spatch
- $(MAKE) STATIC="-ccopt -static" spatch.opt
- cp spatch.opt spatch
-
-purebytecode:
- rm -f spatch.opt spatch
- $(MAKE) BYTECODE_STATIC="" spatch
-
-
-##############################################################################
-# Install
-##############################################################################
-
-# don't remove DESTDIR, it can be set by package build system like ebuild
-install: all
- mkdir -p $(DESTDIR)$(BINDIR)
- mkdir -p $(DESTDIR)$(LIBDIR)
- mkdir -p $(DESTDIR)$(SHAREDIR)
- mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp spatch $(DESTDIR)$(BINDIR)
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
- @echo ""
- @echo "You can also install spatch by copying the program spatch"
- @echo "(available in this directory) anywhere you want and"
- @echo "give it the right options to find its configuration files."
-
-uninstall:
- rm -f $(DESTDIR)$(BINDIR)/spatch
- rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
- rm -f $(DESTDIR)$(SHAREDIR)/standard.h
- rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
- rm -rf $(DESTDIR)$(SHAREDIR)/python/coccilib
- rm -f $(DESTDIR)$(MANDIR)/man1/spatch.1
-
-
-
-version:
- @echo $(VERSION)
-
-
-##############################################################################
-# Package rules
-##############################################################################
-
-PACKAGE=coccinelle-$(VERSION)
-
-BINSRC=spatch env.sh env.csh standard.h standard.iso \
- *.txt docs/* \
- demos/foo.* demos/simple.*
-# $(PYLIB) python/coccilib/ demos/printloc.*
-BINSRC2=$(BINSRC:%=$(PACKAGE)/%)
-
-TMP=/tmp
-OCAMLVERSION=$(shell ocaml -version |perl -p -e 's/.*version (.*)/$$1/;')
-
-# Procedure to do first time:
-# cd ~/release
-# cvs checkout coccinelle
-# cd coccinelle
-# cvs update -d -P
-# touch **/*
-# make licensify
-# remember to comment the -g -dtypes in this Makefile
-
-# Procedure to do each time:
-# cvs update
-# make sure that ocaml is the distribution ocaml of /usr/bin, not ~pad/...
-# modify globals/config.ml
-# cd globals/; cvs commit -m"new version" (do not commit from the root!)
-# ./configure --without-python
-# make package
-# make website
-# Check that run an ocaml in /usr/bin
-
-# To test you can try compile and run spatch from different instances
-# like my ~/coccinelle, ~/release/coccinelle, and the /tmp/coccinelle-0.X
-# downloaded from the website.
-
-# For 'make srctar' it must done from a clean
-# repo such as ~/release/coccinelle. It must also be a repo where
-# the scripts/licensify has been run at least once.
-# For the 'make bintar' I can do it from my original repo.
-
-
-package:
- make srctar
- make bintar
- make staticbintar
- make bytecodetar
-
-# I currently pre-generate the parser so the user does not have to
-# install menhir on his machine. I also do a few cleanups like 'rm todo_pos'.
-# You may have first to do a 'make licensify'.
-srctar:
- make clean
- cp -a . $(TMP)/$(PACKAGE)
- cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
- cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE)
- rm -rf $(TMP)/$(PACKAGE)
-
-
-bintar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-staticbintar: all.opt
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make static
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86-static.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-# add ocaml version in name ?
-bytecodetar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make purebytecode
- cd $(TMP); tar cvfz $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-clean::
- rm -f $(PACKAGE)
- rm -f $(PACKAGE)-bin-x86.tgz
- rm -f $(PACKAGE)-bin-x86-static.tgz
- rm -f $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz
-
-
-
-TOLICENSIFY=ctl engine parsing_cocci popl popl09 python
-licensify:
- ocaml tools/licensify.ml
- set -e; for i in $(TOLICENSIFY); do cd $$i; ocaml ../tools/licensify.ml; cd ..; done
-
-# When checking out the source from diku sometimes I have some "X in the future"
-# error messages.
-fixdates:
- echo do 'touch **/*.*'
-
-#fixCVS:
-# cvs update -d -P
-# echo do 'rm -rf **/CVS'
-
-ocamlversion:
- @echo $(OCAMLVERSION)
-
-
-##############################################################################
-# Pad specific rules
-##############################################################################
-
-#TOP=/home/pad/mobile/project-coccinelle
-WEBSITE=/home/pad/mobile/homepage/software/project-coccinelle
-
-website:
- cp $(TMP)/$(PACKAGE).tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86-static.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz $(WEBSITE)
- rm -f $(WEBSITE)/LATEST* $(WEBSITE)/coccinelle-latest.tgz
- cd $(WEBSITE); touch LATEST_IS_$(VERSION); ln -s $(PACKAGE).tgz coccinelle-latest.tgz
-
-
-#TXT=$(wildcard *.txt)
-syncwiki:
-# unison ~/public_html/wiki/wiki-LFS/data/pages/ docs/wiki/
-# set -e; for i in $(TXT); do unison $$i docs/wiki/$$i; done
-
-darcsweb:
-# @echo pull from ~/public_html/darcs/c-coccinelle and c-commons and lib-xxx
-
-DARCSFORESTS=commons \
- parsing_c parsing_cocci engine
-
-update_darcs:
- darcs pull
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs pull; cd ..; done
-
-#darcs diff -u
-diff_darcs:
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs diff -u; cd ..; done
-
-
-##############################################################################
-# Developer rules
-##############################################################################
-
-test: $(TARGET)
- ./$(TARGET) -testall
-
-testparsing:
- ./$(TARGET) -D standard.h -parse_c -dir tests/
-
-
-
-# -inline 0 to see all the functions in the profile.
-# Can also use the profile framework in commons/ and run your program
-# with -profile.
-forprofiling:
- $(MAKE) OPTFLAGS="-p -inline 0 " opt
-
-clean::
- rm -f gmon.out
-
-tags:
- otags -no-mli-tags -r .
-
-dependencygraph:
- find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl09 -I extra > /tmp/dependfull.depend
- ocamldot -lr /tmp/dependfull.depend > /tmp/dependfull.dot
- dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
- ps2pdf /tmp/dependfull.ps /tmp/dependfull.pdf
-
-##############################################################################
-# Misc rules
-##############################################################################
-
-# each member of the project can have its own test.ml. this file is
-# not under CVS.
-test.ml:
- echo "let foo_ctl () = failwith \"there is no foo_ctl formula\"" \
- > test.ml
-
-beforedepend:: test.ml
-
-
-#INC=$(dir $(shell which ocaml))
-#INCX=$(INC:/=)
-#INCY=$(dir $(INCX))
-#INCZ=$(INCY:/=)/lib/ocaml
-#
-#prim.o: prim.c
-# gcc -c -o prim.o -I $(INCZ) prim.c
-
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[iox] *.o *.annot
-
-clean::
- rm -f *~ .*~ *.exe #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i depend; done
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
-
--include Makefile.config
-
-VERSION=$(shell cat globals/config.ml |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=spatch
-
-SRC=flag_cocci.ml cocci.ml testing.ml test.ml main.ml
-
-
-ifeq ($(FEATURE_PYTHON),1)
-PYCMA=pycaml/pycaml.cma
-PYDIR=pycaml
-PYLIB=dllpycaml_stubs.so
-# the following is essential for Coccinelle to compile under gentoo (wierd)
-OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-else
-PYCMA=
-PYDIR=
-PYLIB=
-OPTLIBFLAGS=
-endif
-
-
-SYSLIBS=str.cma unix.cma
-LIBS=commons/commons.cma globals/globals.cma\
- ctl/ctl.cma \
- parsing_cocci/cocci_parser.cma parsing_c/parsing_c.cma \
- engine/cocciengine.cma popl09/popl.cma \
- extra/extra.cma $(PYCMA) python/coccipython.cma
-
-MAKESUBDIRS=commons globals menhirlib $(PYDIR) ctl parsing_cocci parsing_c \
- engine popl09 extra python
-INCLUDEDIRS=commons commons/ocamlextra globals menhirlib $(PYDIR) ctl \
- parsing_cocci parsing_c engine popl09 extra python
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %)
-
-OBJS= $(SRC:.ml=.cmo)
-OPTOBJS= $(SRC:.ml=.cmx)
-
-EXEC=$(TARGET)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-OCAMLCFLAGS= #-g -dtypes # -w A
-
-# for profiling add -p -inline 0
-# but 'make forprofiling' below does that for you.
-# This flag is also used in subdirectories so don't change its name here.
-OPTFLAGS=
-# the following is essential for Coccinelle to compile under gentoo
-# but is now defined above in this file
-#OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-
-# the OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN= #.opt
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep $(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-# can also be set via 'make static'
-STATIC= #-ccopt -static
-
-# can also be unset via 'make purebytecode'
-BYTECODE_STATIC=-custom
-
-##############################################################################
-# Top rules
-##############################################################################
-.PHONY: all all.opt opt top clean configure
-.PHONY: $(MAKESUBDIRS) $(MAKESUBDIRS:%=%.opt) subdirs subdirs.opt
-
-all:
- $(MAKE) subdirs
- $(MAKE) $(EXEC)
-
-opt:
- $(MAKE) subdirs.opt
- $(MAKE) $(EXEC).opt
-
-all.opt: opt
-top: $(EXEC).top
-
-subdirs:
- +for D in $(MAKESUBDIRS); do make $$D ; done
-
-subdirs.opt:
- +for D in $(MAKESUBDIRS); do make $$D.opt ; done
-
-$(MAKESUBDIRS):
- $(MAKE) -C $@ OCAMLCFLAGS="$(OCAMLCFLAGS)" all
-
-$(MAKESUBDIRS:%=%.opt):
- $(MAKE) -C $(@:%.opt=%) OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt
-
-# commons:
-# globals:
-# menhirlib:
-# parsing_cocci:globals menhirlib
-# parsing_c:parsing_cocci
-# ctl:globals commons
-# engine: parsing_cocci parsing_c ctl
-# popl09:engine
-# extra: parsing_cocci parsing_c ctl
-# pycaml:
-# python:pycaml parsing_cocci parsing_c
-#
-# commons.opt:
-# globals.opt:
-# menhirlib.opt:
-# parsing_cocci.opt:globals.opt menhirlib.opt
-# parsing_c.opt:parsing_cocci.opt
-# ctl.opt:globals.opt commons.opt
-# engine.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-# popl09.opt:engine.opt
-# extra.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-# pycaml.opt:
-# python.opt:pycaml.opt parsing_cocci.opt parsing_c.opt
-
-clean::
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
-
-configure:
- ./configure
-
-$(LIBS): #$(MAKESUBDIRS)
-$(LIBS:.cma=.cmxa): #$(MAKESUBDIRS:%=%.opt)
-
-$(OBJS):$(LIBS)
-$(OPTOBJS):$(LIBS:.cma=.cmxa)
-
-$(EXEC): $(LIBS) $(OBJS)
- $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
-
-$(EXEC).opt: $(LIBS:.cma=.cmxa) $(OPTOBJS)
- $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $(OPTLIBFLAGS) $^
-
-$(EXEC).top: $(LIBS) $(OBJS)
- $(OCAMLMKTOP) -custom -o $@ $(SYSLIBS) $^
-
-clean::
- rm -f $(TARGET) $(TARGET).opt $(TARGET).top
-
-clean::
- rm -f dllpycaml_stubs.so
-
-
-.PHONY: tools all configure
-
-tools:
- $(MAKE) -C tools
-clean::
- $(MAKE) -C tools clean
-
-
-static:
- rm -f spatch.opt spatch
- $(MAKE) STATIC="-ccopt -static" spatch.opt
- cp spatch.opt spatch
-
-purebytecode:
- rm -f spatch.opt spatch
- $(MAKE) BYTECODE_STATIC="" spatch
-
-
-##############################################################################
-# Install
-##############################################################################
-
-# don't remove DESTDIR, it can be set by package build system like ebuild
-install: all
- mkdir -p $(DESTDIR)$(BINDIR)
- mkdir -p $(DESTDIR)$(LIBDIR)
- mkdir -p $(DESTDIR)$(SHAREDIR)
- mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp spatch $(DESTDIR)$(BINDIR)
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
- @echo ""
- @echo "You can also install spatch by copying the program spatch"
- @echo "(available in this directory) anywhere you want and"
- @echo "give it the right options to find its configuration files."
-
-uninstall:
- rm -f $(DESTDIR)$(BINDIR)/spatch
- rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
- rm -f $(DESTDIR)$(SHAREDIR)/standard.h
- rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
- rm -rf $(DESTDIR)$(SHAREDIR)/python/coccilib
- rm -f $(DESTDIR)$(MANDIR)/man1/spatch.1
-
-
-
-version:
- @echo $(VERSION)
-
-
-##############################################################################
-# Package rules
-##############################################################################
-
-PACKAGE=coccinelle-$(VERSION)
-
-BINSRC=spatch env.sh env.csh standard.h standard.iso \
- *.txt docs/* \
- demos/foo.* demos/simple.*
-# $(PYLIB) python/coccilib/ demos/printloc.*
-BINSRC2=$(BINSRC:%=$(PACKAGE)/%)
-
-TMP=/tmp
-OCAMLVERSION=$(shell ocaml -version |perl -p -e 's/.*version (.*)/$$1/;')
-
-# Procedure to do first time:
-# cd ~/release
-# cvs checkout coccinelle
-# cd coccinelle
-# cvs update -d -P
-# touch **/*
-# make licensify
-# remember to comment the -g -dtypes in this Makefile
-
-# Procedure to do each time:
-# cvs update
-# make sure that ocaml is the distribution ocaml of /usr/bin, not ~pad/...
-# modify globals/config.ml
-# cd globals/; cvs commit -m"new version" (do not commit from the root!)
-# ./configure --without-python
-# make package
-# make website
-# Check that run an ocaml in /usr/bin
-
-# To test you can try compile and run spatch from different instances
-# like my ~/coccinelle, ~/release/coccinelle, and the /tmp/coccinelle-0.X
-# downloaded from the website.
-
-# For 'make srctar' it must done from a clean
-# repo such as ~/release/coccinelle. It must also be a repo where
-# the scripts/licensify has been run at least once.
-# For the 'make bintar' I can do it from my original repo.
-
-
-package:
- make srctar
- make bintar
- make staticbintar
- make bytecodetar
-
-# I currently pre-generate the parser so the user does not have to
-# install menhir on his machine. I also do a few cleanups like 'rm todo_pos'.
-# You may have first to do a 'make licensify'.
-srctar:
- make clean
- cp -a . $(TMP)/$(PACKAGE)
- cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
- cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE)
- rm -rf $(TMP)/$(PACKAGE)
-
-
-bintar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-staticbintar: all.opt
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make static
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86-static.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-# add ocaml version in name ?
-bytecodetar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make purebytecode
- cd $(TMP); tar cvfz $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-clean::
- rm -f $(PACKAGE)
- rm -f $(PACKAGE)-bin-x86.tgz
- rm -f $(PACKAGE)-bin-x86-static.tgz
- rm -f $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz
-
-
-
-TOLICENSIFY=ctl engine parsing_cocci popl popl09 python
-licensify:
- ocaml tools/licensify.ml
- set -e; for i in $(TOLICENSIFY); do cd $$i; ocaml ../tools/licensify.ml; cd ..; done
-
-# When checking out the source from diku sometimes I have some "X in the future"
-# error messages.
-fixdates:
- echo do 'touch **/*.*'
-
-#fixCVS:
-# cvs update -d -P
-# echo do 'rm -rf **/CVS'
-
-ocamlversion:
- @echo $(OCAMLVERSION)
-
-
-##############################################################################
-# Pad specific rules
-##############################################################################
-
-#TOP=/home/pad/mobile/project-coccinelle
-WEBSITE=/home/pad/mobile/homepage/software/project-coccinelle
-
-website:
- cp $(TMP)/$(PACKAGE).tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86-static.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz $(WEBSITE)
- rm -f $(WEBSITE)/LATEST* $(WEBSITE)/coccinelle-latest.tgz
- cd $(WEBSITE); touch LATEST_IS_$(VERSION); ln -s $(PACKAGE).tgz coccinelle-latest.tgz
-
-
-#TXT=$(wildcard *.txt)
-syncwiki:
-# unison ~/public_html/wiki/wiki-LFS/data/pages/ docs/wiki/
-# set -e; for i in $(TXT); do unison $$i docs/wiki/$$i; done
-
-darcsweb:
-# @echo pull from ~/public_html/darcs/c-coccinelle and c-commons and lib-xxx
-
-DARCSFORESTS=commons \
- parsing_c parsing_cocci engine
-
-update_darcs:
- darcs pull
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs pull; cd ..; done
-
-#darcs diff -u
-diff_darcs:
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs diff -u; cd ..; done
-
-
-##############################################################################
-# Developer rules
-##############################################################################
-
-test: $(TARGET)
- ./$(TARGET) -testall
-
-testparsing:
- ./$(TARGET) -D standard.h -parse_c -dir tests/
-
-
-
-# -inline 0 to see all the functions in the profile.
-# Can also use the profile framework in commons/ and run your program
-# with -profile.
-forprofiling:
- $(MAKE) OPTFLAGS="-p -inline 0 " opt
-
-clean::
- rm -f gmon.out
-
-tags:
- otags -no-mli-tags -r .
-
-dependencygraph:
- find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl09 -I extra > /tmp/dependfull.depend
- ocamldot -lr /tmp/dependfull.depend > /tmp/dependfull.dot
- dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
- ps2pdf /tmp/dependfull.ps /tmp/dependfull.pdf
-
-##############################################################################
-# Misc rules
-##############################################################################
-
-# each member of the project can have its own test.ml. this file is
-# not under CVS.
-test.ml:
- echo "let foo_ctl () = failwith \"there is no foo_ctl formula\"" \
- > test.ml
-
-beforedepend:: test.ml
-
-
-#INC=$(dir $(shell which ocaml))
-#INCX=$(INC:/=)
-#INCY=$(dir $(INCX))
-#INCZ=$(INCY:/=)/lib/ocaml
-#
-#prim.o: prim.c
-# gcc -c -o prim.o -I $(INCZ) prim.c
-
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[iox] *.o *.annot
-
-clean::
- rm -f *~ .*~ *.exe #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i depend; done
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
-
--include Makefile.config
-
-VERSION=$(shell cat globals/config.ml |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=spatch
-
-SRC=flag_cocci.ml cocci.ml testing.ml test.ml main.ml
-
-
-ifeq ($(FEATURE_PYTHON),1)
-PYCMA=pycaml/pycaml.cma
-PYDIR=pycaml
-PYLIB=dllpycaml_stubs.so
-# the following is essential for Coccinelle to compile under gentoo (wierd)
-OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-else
-PYCMA=
-PYDIR=
-PYLIB=
-OPTLIBFLAGS=
-endif
-
-
-SYSLIBS=str.cma unix.cma
-LIBS=commons/commons.cma globals/globals.cma\
- ctl/ctl.cma \
- parsing_cocci/cocci_parser.cma parsing_c/parsing_c.cma \
- engine/cocciengine.cma popl09/popl.cma \
- extra/extra.cma $(PYCMA) python/coccipython.cma
-
-MAKESUBDIRS=commons globals menhirlib $(PYDIR) ctl parsing_cocci parsing_c \
- engine popl09 extra python
-INCLUDEDIRS=commons commons/ocamlextra globals menhirlib $(PYDIR) ctl \
- parsing_cocci parsing_c engine popl09 extra python
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %)
-
-OBJS= $(SRC:.ml=.cmo)
-OPTOBJS= $(SRC:.ml=.cmx)
-
-EXEC=$(TARGET)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-OCAMLCFLAGS= #-g -dtypes # -w A
-
-# for profiling add -p -inline 0
-# but 'make forprofiling' below does that for you.
-# This flag is also used in subdirectories so don't change its name here.
-OPTFLAGS=
-# the following is essential for Coccinelle to compile under gentoo
-# but is now defined above in this file
-#OPTLIBFLAGS=-cclib dllpycaml_stubs.so
-
-# the OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN= #.opt
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep $(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-# can also be set via 'make static'
-STATIC= #-ccopt -static
-
-# can also be unset via 'make purebytecode'
-BYTECODE_STATIC=-custom
-
-##############################################################################
-# Top rules
-##############################################################################
-.PHONY: all all.opt opt top clean configure
-.PHONY: $(MAKESUBDIRS) $(MAKESUBDIRS:%=%.opt) subdirs subdirs.opt
-
-all:
- $(MAKE) subdirs
- $(MAKE) $(EXEC)
-
-opt:
- $(MAKE) subdirs.opt
- $(MAKE) $(EXEC).opt
-
-all.opt: opt
-top: $(EXEC).top
-
-subdirs:
- +for D in $(MAKESUBDIRS); do $(MAKE) $$D ; done
-
-subdirs.opt:
- +for D in $(MAKESUBDIRS); do $(MAKE) $$D.opt ; done
-
-$(MAKESUBDIRS):
- $(MAKE) -C $@ OCAMLCFLAGS="$(OCAMLCFLAGS)" all
-
-$(MAKESUBDIRS:%=%.opt):
- $(MAKE) -C $(@:%.opt=%) OCAMLCFLAGS="$(OCAMLCFLAGS)" all.opt
-
-# commons:
-# globals:
-# menhirlib:
-# parsing_cocci:globals menhirlib
-# parsing_c:parsing_cocci
-# ctl:globals commons
-# engine: parsing_cocci parsing_c ctl
-# popl09:engine
-# extra: parsing_cocci parsing_c ctl
-# pycaml:
-# python:pycaml parsing_cocci parsing_c
-#
-# commons.opt:
-# globals.opt:
-# menhirlib.opt:
-# parsing_cocci.opt:globals.opt menhirlib.opt
-# parsing_c.opt:parsing_cocci.opt
-# ctl.opt:globals.opt commons.opt
-# engine.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-# popl09.opt:engine.opt
-# extra.opt: parsing_cocci.opt parsing_c.opt ctl.opt
-# pycaml.opt:
-# python.opt:pycaml.opt parsing_cocci.opt parsing_c.opt
-
-clean::
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
-
-configure:
- ./configure
-
-$(LIBS): $(MAKESUBDIRS)
-$(LIBS:.cma=.cmxa): $(MAKESUBDIRS:%=%.opt)
-
-$(OBJS):$(LIBS)
-$(OPTOBJS):$(LIBS:.cma=.cmxa)
-
-$(EXEC): $(LIBS) $(OBJS)
- $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
-
-$(EXEC).opt: $(LIBS:.cma=.cmxa) $(OPTOBJS)
- $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $(OPTLIBFLAGS) $^
-
-$(EXEC).top: $(LIBS) $(OBJS)
- $(OCAMLMKTOP) -custom -o $@ $(SYSLIBS) $^
-
-clean::
- rm -f $(TARGET) $(TARGET).opt $(TARGET).top
-
-clean::
- rm -f dllpycaml_stubs.so
-
-
-.PHONY: tools all configure
-
-tools:
- $(MAKE) -C tools
-clean::
- $(MAKE) -C tools clean
-
-
-static:
- rm -f spatch.opt spatch
- $(MAKE) STATIC="-ccopt -static" spatch.opt
- cp spatch.opt spatch
-
-purebytecode:
- rm -f spatch.opt spatch
- $(MAKE) BYTECODE_STATIC="" spatch
-
-
-##############################################################################
-# Install
-##############################################################################
-
-# don't remove DESTDIR, it can be set by package build system like ebuild
-install: all
- mkdir -p $(DESTDIR)$(BINDIR)
- mkdir -p $(DESTDIR)$(LIBDIR)
- mkdir -p $(DESTDIR)$(SHAREDIR)
- mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp spatch $(DESTDIR)$(BINDIR)
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
- @echo ""
- @echo "You can also install spatch by copying the program spatch"
- @echo "(available in this directory) anywhere you want and"
- @echo "give it the right options to find its configuration files."
-
-uninstall:
- rm -f $(DESTDIR)$(BINDIR)/spatch
- rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
- rm -f $(DESTDIR)$(SHAREDIR)/standard.h
- rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
- rm -rf $(DESTDIR)$(SHAREDIR)/python/coccilib
- rm -f $(DESTDIR)$(MANDIR)/man1/spatch.1
-
-
-
-version:
- @echo $(VERSION)
-
-
-##############################################################################
-# Package rules
-##############################################################################
-
-PACKAGE=coccinelle-$(VERSION)
-
-BINSRC=spatch env.sh env.csh standard.h standard.iso \
- *.txt docs/* \
- demos/foo.* demos/simple.*
-# $(PYLIB) python/coccilib/ demos/printloc.*
-BINSRC2=$(BINSRC:%=$(PACKAGE)/%)
-
-TMP=/tmp
-OCAMLVERSION=$(shell ocaml -version |perl -p -e 's/.*version (.*)/$$1/;')
-
-# Procedure to do first time:
-# cd ~/release
-# cvs checkout coccinelle
-# cd coccinelle
-# cvs update -d -P
-# touch **/*
-# make licensify
-# remember to comment the -g -dtypes in this Makefile
-
-# Procedure to do each time:
-# cvs update
-# make sure that ocaml is the distribution ocaml of /usr/bin, not ~pad/...
-# modify globals/config.ml
-# cd globals/; cvs commit -m"new version" (do not commit from the root!)
-# ./configure --without-python
-# make package
-# make website
-# Check that run an ocaml in /usr/bin
-
-# To test you can try compile and run spatch from different instances
-# like my ~/coccinelle, ~/release/coccinelle, and the /tmp/coccinelle-0.X
-# downloaded from the website.
-
-# For 'make srctar' it must done from a clean
-# repo such as ~/release/coccinelle. It must also be a repo where
-# the scripts/licensify has been run at least once.
-# For the 'make bintar' I can do it from my original repo.
-
-
-package:
- make srctar
- make bintar
- make staticbintar
- make bytecodetar
-
-# I currently pre-generate the parser so the user does not have to
-# install menhir on his machine. I also do a few cleanups like 'rm todo_pos'.
-# You may have first to do a 'make licensify'.
-srctar:
- make clean
- cp -a . $(TMP)/$(PACKAGE)
- cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
- cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE)
- rm -rf $(TMP)/$(PACKAGE)
-
-
-bintar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-staticbintar: all.opt
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make static
- cd $(TMP); tar cvfz $(PACKAGE)-bin-x86-static.tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-# add ocaml version in name ?
-bytecodetar: all
- rm -f $(TMP)/$(PACKAGE)
- ln -s `pwd` $(TMP)/$(PACKAGE)
- make purebytecode
- cd $(TMP); tar cvfz $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz --exclude-vcs $(BINSRC2)
- rm -f $(TMP)/$(PACKAGE)
-
-clean::
- rm -f $(PACKAGE)
- rm -f $(PACKAGE)-bin-x86.tgz
- rm -f $(PACKAGE)-bin-x86-static.tgz
- rm -f $(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz
-
-
-
-TOLICENSIFY=ctl engine parsing_cocci popl popl09 python
-licensify:
- ocaml tools/licensify.ml
- set -e; for i in $(TOLICENSIFY); do cd $$i; ocaml ../tools/licensify.ml; cd ..; done
-
-# When checking out the source from diku sometimes I have some "X in the future"
-# error messages.
-fixdates:
- echo do 'touch **/*.*'
-
-#fixCVS:
-# cvs update -d -P
-# echo do 'rm -rf **/CVS'
-
-ocamlversion:
- @echo $(OCAMLVERSION)
-
-
-##############################################################################
-# Pad specific rules
-##############################################################################
-
-#TOP=/home/pad/mobile/project-coccinelle
-WEBSITE=/home/pad/mobile/homepage/software/project-coccinelle
-
-website:
- cp $(TMP)/$(PACKAGE).tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-x86-static.tgz $(WEBSITE)
- cp $(TMP)/$(PACKAGE)-bin-bytecode-$(OCAMLVERSION).tgz $(WEBSITE)
- rm -f $(WEBSITE)/LATEST* $(WEBSITE)/coccinelle-latest.tgz
- cd $(WEBSITE); touch LATEST_IS_$(VERSION); ln -s $(PACKAGE).tgz coccinelle-latest.tgz
-
-
-#TXT=$(wildcard *.txt)
-syncwiki:
-# unison ~/public_html/wiki/wiki-LFS/data/pages/ docs/wiki/
-# set -e; for i in $(TXT); do unison $$i docs/wiki/$$i; done
-
-darcsweb:
-# @echo pull from ~/public_html/darcs/c-coccinelle and c-commons and lib-xxx
-
-DARCSFORESTS=commons \
- parsing_c parsing_cocci engine
-
-update_darcs:
- darcs pull
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs pull; cd ..; done
-
-#darcs diff -u
-diff_darcs:
- set -e; for i in $(DARCSFORESTS); do cd $$i; darcs diff -u; cd ..; done
-
-
-##############################################################################
-# Developer rules
-##############################################################################
-
-test: $(TARGET)
- ./$(TARGET) -testall
-
-testparsing:
- ./$(TARGET) -D standard.h -parse_c -dir tests/
-
-
-
-# -inline 0 to see all the functions in the profile.
-# Can also use the profile framework in commons/ and run your program
-# with -profile.
-forprofiling:
- $(MAKE) OPTFLAGS="-p -inline 0 " opt
-
-clean::
- rm -f gmon.out
-
-tags:
- otags -no-mli-tags -r .
-
-dependencygraph:
- find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl09 -I extra > /tmp/dependfull.depend
- ocamldot -lr /tmp/dependfull.depend > /tmp/dependfull.dot
- dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
- ps2pdf /tmp/dependfull.ps /tmp/dependfull.pdf
-
-##############################################################################
-# Misc rules
-##############################################################################
-
-# each member of the project can have its own test.ml. this file is
-# not under CVS.
-test.ml:
- echo "let foo_ctl () = failwith \"there is no foo_ctl formula\"" \
- > test.ml
-
-beforedepend:: test.ml
-
-
-#INC=$(dir $(shell which ocaml))
-#INCX=$(INC:/=)
-#INCY=$(dir $(INCX))
-#INCZ=$(INCY:/=)/lib/ocaml
-#
-#prim.o: prim.c
-# gcc -c -o prim.o -I $(INCZ) prim.c
-
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[iox] *.o *.annot
-
-clean::
- rm -f *~ .*~ *.exe #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
- set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i depend; done
-
--include .depend
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-module CCI = Ctlcocci_integration
-module TAC = Type_annoter_c
-
-(*****************************************************************************)
-(* This file is a kind of driver. It gathers all the important functions
- * from coccinelle in one place. The different entities in coccinelle are:
- * - files
- * - astc
- * - astcocci
- * - flow (contain nodes)
- * - ctl (contain rule_elems)
- * This file contains functions to transform one in another.
- *)
-(*****************************************************************************)
-
-(* --------------------------------------------------------------------- *)
-(* C related *)
-(* --------------------------------------------------------------------- *)
-let cprogram_of_file file =
- let (program2, _stat) = Parse_c.parse_print_error_heuristic file in
- program2
-
-let cprogram_of_file_cached file =
- let (program2, _stat) = Parse_c.parse_cache file in
- if !Flag_cocci.ifdef_to_if
- then
- program2 +> Parse_c.with_program2 (fun asts ->
- Cpp_ast_c.cpp_ifdef_statementize asts
- )
- else program2
-
-let cfile_of_program program2_with_ppmethod outf =
- Unparse_c.pp_program program2_with_ppmethod outf
-
-(* for memoization, contains only one entry, the one for the SP *)
-let _hparse = Hashtbl.create 101
-let _hctl = Hashtbl.create 101
-
-(* --------------------------------------------------------------------- *)
-(* Cocci related *)
-(* --------------------------------------------------------------------- *)
-let sp_of_file2 file iso =
- Common.memoized _hparse (file, iso) (fun () ->
- Parse_cocci.process file iso false)
-let sp_of_file file iso =
- Common.profile_code "parse cocci" (fun () -> sp_of_file2 file iso)
-
-
-(* --------------------------------------------------------------------- *)
-(* Flow related *)
-(* --------------------------------------------------------------------- *)
-let print_flow flow =
- Ograph_extended.print_ograph_mutable flow "/tmp/test.dot" true
-
-
-let ast_to_flow_with_error_messages2 x =
- let flowopt =
- try Ast_to_flow.ast_to_control_flow x
- with Ast_to_flow.Error x ->
- Ast_to_flow.report_error x;
- None
- in
- flowopt +> do_option (fun flow ->
- (* This time even if there is a deadcode, we still have a
- * flow graph, so I can try the transformation and hope the
- * deadcode will not bother us.
- *)
- try Ast_to_flow.deadcode_detection flow
- with Ast_to_flow.Error (Ast_to_flow.DeadCode x) ->
- Ast_to_flow.report_error (Ast_to_flow.DeadCode x);
- );
- flowopt
-let ast_to_flow_with_error_messages a =
- Common.profile_code "flow" (fun () -> ast_to_flow_with_error_messages2 a)
-
-
-(* --------------------------------------------------------------------- *)
-(* Ctl related *)
-(* --------------------------------------------------------------------- *)
-let ctls_of_ast2 ast ua pos =
- List.map2
- (function ast -> function (ua,pos) ->
- List.combine
- (if !Flag_cocci.popl
- then Popl.popl ast
- else Asttoctl2.asttoctl ast ua pos)
- (Asttomember.asttomember ast ua))
- ast (List.combine ua pos)
-
-let ctls_of_ast ast ua =
- Common.profile_code "asttoctl2" (fun () -> ctls_of_ast2 ast ua)
-
-(*****************************************************************************)
-(* Some debugging functions *)
-(*****************************************************************************)
-
-(* the inputs *)
-
-let show_or_not_cfile2 cfile =
- if !Flag_cocci.show_c then begin
- Common.pr2_xxxxxxxxxxxxxxxxx ();
- pr2 ("processing C file: " ^ cfile);
- Common.pr2_xxxxxxxxxxxxxxxxx ();
- Common.command2 ("cat " ^ cfile);
- end
-let show_or_not_cfile a =
- Common.profile_code "show_xxx" (fun () -> show_or_not_cfile2 a)
-
-let show_or_not_cfiles cfiles = List.iter show_or_not_cfile cfiles
-
-
-let show_or_not_cocci2 coccifile isofile =
- if !Flag_cocci.show_cocci then begin
- Common.pr2_xxxxxxxxxxxxxxxxx ();
- pr2 ("processing semantic patch file: " ^ coccifile);
- isofile +> (fun s -> pr2 ("with isos from: " ^ s));
- Common.pr2_xxxxxxxxxxxxxxxxx ();
- Common.command2 ("cat " ^ coccifile);
- pr2 "";
- end
-let show_or_not_cocci a b =
- Common.profile_code "show_xxx" (fun () -> show_or_not_cocci2 a b)
-
-
-(* the output *)
-
-let show_or_not_diff2 cfile outfile show_only_minus =
- if !Flag_cocci.show_diff then begin
- match Common.fst(Compare_c.compare_default cfile outfile) with
- Compare_c.Correct -> () (* diff only in spacing, etc *)
- | _ ->
- (* may need --strip-trailing-cr under windows *)
- pr2 "diff = ";
-
- let line =
- match !Flag_parsing_c.diff_lines with
- | None -> "diff -u -p " ^ cfile ^ " " ^ outfile
- | Some n -> "diff -U "^n^" -p "^cfile^" "^outfile in
- let xs =
- let res = Common.cmd_to_list line in
- match (!Flag.patch,res) with
- (* create something that looks like the output of patch *)
- (Some prefix,minus_file::plus_file::rest) ->
- let drop_prefix file =
- if prefix = ""
- then "/"^file
- else
- (match Str.split (Str.regexp prefix) file with
- [base_file] -> base_file
- | _ -> failwith "prefix not found in the old file name") in
- let diff_line =
- match List.rev(Str.split (Str.regexp " ") line) with
- new_file::old_file::cmdrev ->
- if !Flag.sgrep_mode2
- then
- String.concat " "
- (List.rev ("/tmp/nothing" :: old_file :: cmdrev))
- else
- let old_base_file = drop_prefix old_file in
- String.concat " "
- (List.rev
- (("b"^old_base_file)::("a"^old_base_file)::cmdrev))
- | _ -> failwith "bad command" in
- let (minus_line,plus_line) =
- if !Flag.sgrep_mode2
- then (minus_file,plus_file)
- else
- match (Str.split (Str.regexp "[ \t]") minus_file,
- Str.split (Str.regexp "[ \t]") plus_file) with
- ("---"::old_file::old_rest,"+++"::new_file::new_rest) ->
- let old_base_file = drop_prefix old_file in
- (String.concat " "
- ("---"::("a"^old_base_file)::old_rest),
- String.concat " "
- ("+++"::("b"^old_base_file)::new_rest))
- | (l1,l2) ->
- failwith
- (Printf.sprintf "bad diff header lines: %s %s"
- (String.concat ":" l1) (String.concat ":" l2)) in
- diff_line::minus_line::plus_line::rest
- | _ -> res in
- xs +> List.iter (fun s ->
- if s =~ "^\\+" && show_only_minus
- then ()
- else pr s)
- end
-let show_or_not_diff a b c =
- Common.profile_code "show_xxx" (fun () -> show_or_not_diff2 a b c)
-
-
-(* the derived input *)
-
-let show_or_not_ctl_tex2 astcocci ctls =
- if !Flag_cocci.show_ctl_tex then begin
- Ctltotex.totex ("/tmp/__cocci_ctl.tex") astcocci ctls;
- Common.command2 ("cd /tmp; latex __cocci_ctl.tex; " ^
- "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
- "gv __cocci_ctl.ps &");
- end
-let show_or_not_ctl_tex a b =
- Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_tex2 a b)
-
-
-
-let show_or_not_rule_name ast rulenb =
- if !Flag_cocci.show_ctl_text or !Flag.show_trying or
- !Flag.show_transinfo or !Flag_cocci.show_binding_in_out
- then
- begin
- let name =
- match ast with
- Ast_cocci.CocciRule (nm, (deps, drops, exists), x, _, _) -> nm
- | _ -> i_to_s rulenb in
- Common.pr_xxxxxxxxxxxxxxxxx ();
- pr (name ^ " = ");
- Common.pr_xxxxxxxxxxxxxxxxx ()
- end
-
-let show_or_not_scr_rule_name rulenb =
- if !Flag_cocci.show_ctl_text or !Flag.show_trying or
- !Flag.show_transinfo or !Flag_cocci.show_binding_in_out
- then
- begin
- let name = i_to_s rulenb in
- Common.pr_xxxxxxxxxxxxxxxxx ();
- pr ("script rule " ^ name ^ " = ");
- Common.pr_xxxxxxxxxxxxxxxxx ()
- end
-
-let show_or_not_ctl_text2 ctl ast rulenb =
- if !Flag_cocci.show_ctl_text then begin
-
- adjust_pp_with_indent (fun () ->
- Format.force_newline();
- Pretty_print_cocci.print_plus_flag := true;
- Pretty_print_cocci.print_minus_flag := true;
- Pretty_print_cocci.unparse ast;
- );
-
- pr "CTL = ";
- let (ctl,_) = ctl in
- adjust_pp_with_indent (fun () ->
- Format.force_newline();
- Pretty_print_engine.pp_ctlcocci
- !Flag_cocci.show_mcodekind_in_ctl !Flag_cocci.inline_let_ctl ctl;
- );
- pr "";
- end
-let show_or_not_ctl_text a b c =
- Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_text2 a b c)
-
-
-
-(* running information *)
-let get_celem celem : string =
- match celem with
- Ast_c.Definition ({Ast_c.f_name = funcs;},_) -> funcs
- | Ast_c.Declaration
- (Ast_c.DeclList ([{Ast_c.v_namei = Some ((s, _),_);}, _], _)) -> s
- | _ -> ""
-
-let show_or_not_celem2 prelude celem =
- let (tag,trying) =
- (match celem with
- | Ast_c.Definition ({Ast_c.f_name = funcs;},_) ->
- Flag.current_element := funcs;
- (" function: ",funcs)
- | Ast_c.Declaration
- (Ast_c.DeclList ([{Ast_c.v_namei = Some ((s, _),_);}, _], _)) ->
- Flag.current_element := s;
- (" variable ",s);
- | _ ->
- Flag.current_element := "something_else";
- (" ","something else");
- ) in
- if !Flag.show_trying then pr2 (prelude ^ tag ^ trying)
-
-let show_or_not_celem a b =
- Common.profile_code "show_xxx" (fun () -> show_or_not_celem2 a b)
-
-
-let show_or_not_trans_info2 trans_info =
- if !Flag.show_transinfo then begin
- if null trans_info then pr2 "transformation info is empty"
- else begin
- pr2 "transformation info returned:";
- let trans_info =
- List.sort (function (i1,_,_) -> function (i2,_,_) -> compare i1 i2)
- trans_info
- in
- indent_do (fun () ->
- trans_info +> List.iter (fun (i, subst, re) ->
- pr2 ("transform state: " ^ (Common.i_to_s i));
- indent_do (fun () ->
- adjust_pp_with_indent_and_header "with rule_elem: " (fun () ->
- Pretty_print_cocci.print_plus_flag := true;
- Pretty_print_cocci.print_minus_flag := true;
- Pretty_print_cocci.rule_elem "" re;
- );
- adjust_pp_with_indent_and_header "with binding: " (fun () ->
- Pretty_print_engine.pp_binding subst;
- );
- )
- );
- )
- end
- end
-let show_or_not_trans_info a =
- Common.profile_code "show_xxx" (fun () -> show_or_not_trans_info2 a)
-
-
-
-let show_or_not_binding2 s binding =
- if !Flag_cocci.show_binding_in_out then begin
- adjust_pp_with_indent_and_header ("binding " ^ s ^ " = ") (fun () ->
- Pretty_print_engine.pp_binding binding
- )
- end
-let show_or_not_binding a b =
- Common.profile_code "show_xxx" (fun () -> show_or_not_binding2 a b)
-
-
-
-(*****************************************************************************)
-(* Some helper functions *)
-(*****************************************************************************)
-
-let worth_trying cfiles tokens =
- (* drop the following line for a list of list by rules. since we don't
- allow multiple minirules, all the tokens within a rule should be in
- a single CFG entity *)
- let tokens = Common.union_all tokens in
- if not !Flag_cocci.windows && not (null tokens)
- then
- (* could also modify the code in get_constants.ml *)
- let tokens = tokens +> List.map (fun s ->
- match () with
- | _ when s =~ "^[A-Za-z_][A-Za-z_0-9]*$" ->
- "\\b" ^ s ^ "\\b"
-
- | _ when s =~ "^[A-Za-z_]" ->
- "\\b" ^ s
-
- | _ when s =~ ".*[A-Za-z_]$" ->
- s ^ "\\b"
- | _ -> s
-
- ) in
- let com = sprintf "egrep -q '(%s)' %s" (join "|" tokens) (join " " cfiles)
- in
- (match Sys.command com with
- | 0 (* success *) -> true
- | _ (* failure *) ->
- (if !Flag.show_misc
- then Printf.printf "grep failed: %s\n" com);
- false (* no match, so not worth trying *)
- )
- else true
-
-let check_macro_in_sp_and_adjust tokens =
- let tokens = Common.union_all tokens in
- tokens +> List.iter (fun s ->
- if Hashtbl.mem !Parsing_hacks._defs s
- then begin
- pr2 "warning: macro in semantic patch was in macro definitions";
- pr2 ("disabling macro expansion for " ^ s);
- Hashtbl.remove !Parsing_hacks._defs s
- end
- )
-
-
-let contain_loop gopt =
- match gopt with
- | Some g ->
- g#nodes#tolist +> List.exists (fun (xi, node) ->
- Control_flow_c.extract_is_loop node
- )
- | None -> true (* means nothing, if no g then will not model check *)
-
-
-
-let sp_contain_typed_metavar_z toplevel_list_list =
- let bind x y = x or y in
- let option_default = false in
- let mcode _ _ = option_default in
- let donothing r k e = k e in
-
- let expression r k e =
- match Ast_cocci.unwrap e with
- | Ast_cocci.MetaExpr (_,_,_,Some t,_,_) -> true
- | Ast_cocci.MetaExpr (_,_,_,_,Ast_cocci.LocalID,_) -> true
- | _ -> k e
- in
-
- let combiner =
- Visitor_ast.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing expression donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing
- in
- toplevel_list_list +>
- List.exists
- (function (nm,_,rule) ->
- (List.exists combiner.Visitor_ast.combiner_top_level rule))
-
-
-let sp_contain_typed_metavar rules =
- sp_contain_typed_metavar_z
- (List.map
- (function x ->
- match x with
- Ast_cocci.CocciRule (a,b,c,d,_) -> (a,b,c)
- | _ -> failwith "error in filter")
- (List.filter
- (function x ->
- match x with
- Ast_cocci.CocciRule (a,b,c,d,Ast_cocci.Normal) -> true
- | _ -> false)
- rules))
-
-
-
-(* finding among the #include the one that we need to parse
- * because they may contain useful type definition or because
- * we may have to modify them
- *
- * For the moment we base in part our heuristic on the name of the file, e.g.
- * serio.c is related we think to #include <linux/serio.h>
- *)
-
-let (includes_to_parse:
- (Common.filename * Parse_c.program2) list ->
- Flag_cocci.include_options -> 'a) = fun xs choose_includes ->
- match choose_includes with
- Flag_cocci.I_UNSPECIFIED -> failwith "not possible"
- | Flag_cocci.I_NO_INCLUDES -> []
- | x ->
- let all_includes = x = Flag_cocci.I_ALL_INCLUDES in
- xs +> List.map (fun (file, cs) ->
- let dir = Common.dirname file in
-
- cs +> Common.map_filter (fun (c,_info_item) ->
- match c with
- | Ast_c.CppTop
- (Ast_c.Include
- {Ast_c.i_include = ((x,ii)); i_rel_pos = info_h_pos;}) ->
- (match x with
- | Ast_c.Local xs ->
- let f = Filename.concat dir (Common.join "/" xs) in
- (* for our tests, all the files are flat in the current dir *)
- if not (Sys.file_exists f) && !Flag_cocci.relax_include_path
- then
- let attempt2 = Filename.concat dir (Common.last xs) in
- if not (Sys.file_exists f) && all_includes
- then Some (Filename.concat !Flag_cocci.include_path
- (Common.join "/" xs))
- else Some attempt2
- else Some f
-
- | Ast_c.NonLocal xs ->
- if all_includes ||
- Common.fileprefix (Common.last xs) = Common.fileprefix file
- then
- Some (Filename.concat !Flag_cocci.include_path
- (Common.join "/" xs))
- else None
- | Ast_c.Wierd _ -> None
- )
- | _ -> None))
- +> List.concat
- +> Common.uniq
-
-let rec interpret_dependencies local global = function
- Ast_cocci.Dep s -> List.mem s local
- | Ast_cocci.AntiDep s ->
- (if !Flag_ctl.steps != None
- then failwith "steps and ! dependency incompatible");
- not (List.mem s local)
- | Ast_cocci.EverDep s -> List.mem s global
- | Ast_cocci.NeverDep s ->
- (if !Flag_ctl.steps != None
- then failwith "steps and ! dependency incompatible");
- not (List.mem s global)
- | Ast_cocci.AndDep(s1,s2) ->
- (interpret_dependencies local global s1) &&
- (interpret_dependencies local global s2)
- | Ast_cocci.OrDep(s1,s2) ->
- (interpret_dependencies local global s1) or
- (interpret_dependencies local global s2)
- | Ast_cocci.NoDep -> true
-
-let rec print_dependencies str local global dep =
- if !Flag_cocci.show_dependencies
- then
- begin
- pr2 str;
- let seen = ref [] in
- let rec loop = function
- Ast_cocci.Dep s | Ast_cocci.AntiDep s ->
- if not (List.mem s !seen)
- then
- begin
- if List.mem s local
- then pr2 (s^" satisfied")
- else pr2 (s^" not satisfied");
- seen := s :: !seen
- end
- | Ast_cocci.EverDep s | Ast_cocci.NeverDep s ->
- if not (List.mem s !seen)
- then
- begin
- if List.mem s global
- then pr2 (s^" satisfied")
- else pr2 (s^" not satisfied");
- seen := s :: !seen
- end
- | Ast_cocci.AndDep(s1,s2) ->
- loop s1;
- loop s2
- | Ast_cocci.OrDep(s1,s2) ->
- loop s1;
- loop s2
- | Ast_cocci.NoDep -> () in
- loop dep
- end
-
-
-
-(* --------------------------------------------------------------------- *)
-(* #include relative position in the file *)
-(* --------------------------------------------------------------------- *)
-
-(* compute the set of new prefixes
- * on
- * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
- * "a/b/c/x";
- * "a/x";
- * "b/x";
- * it would give for the first element
- * ""; "a"; "a/b"; "a/b/x"
- * for the second
- * "a/b/c/x"
- *
- * update: if the include is inside a ifdef a put nothing. cf -test incl.
- * this is because we dont want code added inside ifdef.
- *)
-
-let compute_new_prefixes xs =
- xs +> Common.map_withenv (fun already xs ->
- let subdirs_prefixes = Common.inits xs in
- let new_first = subdirs_prefixes +> List.filter (fun x ->
- not (List.mem x already)
- )
- in
- new_first,
- new_first @ already
- ) []
- +> fst
-
-
-(* does via side effect on the ref in the Include in Ast_c *)
-let rec update_include_rel_pos cs =
- let only_include = cs +> Common.map_filter (fun c ->
- match c with
- | Ast_c.CppTop (Ast_c.Include {Ast_c.i_include = ((x,_));
- i_rel_pos = aref;
- i_is_in_ifdef = inifdef}) ->
- (match x with
- | Ast_c.Wierd _ -> None
- | _ ->
- if inifdef
- then None
- else Some (x, aref)
- )
- | _ -> None
- )
- in
- let (locals, nonlocals) =
- only_include +> Common.partition_either (fun (c, aref) ->
- match c with
- | Ast_c.Local x -> Left (x, aref)
- | Ast_c.NonLocal x -> Right (x, aref)
- | Ast_c.Wierd x -> raise Impossible
- ) in
-
- update_rel_pos_bis locals;
- update_rel_pos_bis nonlocals;
- cs
-and update_rel_pos_bis xs =
- let xs' = List.map fst xs in
- let the_first = compute_new_prefixes xs' in
- let the_last = List.rev (compute_new_prefixes (List.rev xs')) in
- let merged = Common.zip xs (Common.zip the_first the_last) in
- merged +> List.iter (fun ((x, aref), (the_first, the_last)) ->
- aref := Some
- {
- Ast_c.first_of = the_first;
- Ast_c.last_of = the_last;
- }
- )
-
-
-
-
-
-
-(*****************************************************************************)
-(* All the information needed around the C elements and Cocci rules *)
-(*****************************************************************************)
-
-type toplevel_c_info = {
- ast_c: Ast_c.toplevel; (* contain refs so can be modified *)
- tokens_c: Parser_c.token list;
- fullstring: string;
-
- flow: Control_flow_c.cflow option; (* it's the "fixed" flow *)
- contain_loop: bool;
-
- env_typing_before: TAC.environment;
- env_typing_after: TAC.environment;
-
- was_modified: bool ref;
-
- (* id: int *)
-}
-
-type toplevel_cocci_info_script_rule = {
- scr_ast_rule: string * (string * (string * string)) list * string;
- language: string;
- scr_dependencies: Ast_cocci.dependency;
- scr_ruleid: int;
- script_code: string;
-}
-
-type toplevel_cocci_info_cocci_rule = {
- ctl: Lib_engine.ctlcocci * (CCI.pred list list);
- metavars: Ast_cocci.metavar list;
- ast_rule: Ast_cocci.rule;
- isexp: bool; (* true if + code is an exp, only for Flag.make_hrule *)
-
- rulename: string;
- dependencies: Ast_cocci.dependency;
- (* There are also some hardcoded rule names in parse_cocci.ml:
- * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
- *)
- dropped_isos: string list;
- free_vars: Ast_cocci.meta_name list;
- negated_pos_vars: Ast_cocci.meta_name list;
- used_after: Ast_cocci.meta_name list;
- positions: Ast_cocci.meta_name list;
-
- ruleid: int;
- ruletype: Ast_cocci.ruletype;
-
- was_matched: bool ref;
-}
-
-type toplevel_cocci_info =
- ScriptRuleCocciInfo of toplevel_cocci_info_script_rule
- | CocciRuleCocciInfo of toplevel_cocci_info_cocci_rule
-
-type kind_file = Header | Source
-type file_info = {
- fname : string;
- full_fname : string;
- was_modified_once: bool ref;
- asts: toplevel_c_info list;
- fpath : string;
- fkind : kind_file;
-}
-
-let g_contain_typedmetavar = ref false
-
-
-let last_env_toplevel_c_info xs =
- (Common.last xs).env_typing_after
-
-let concat_headers_and_c (ccs: file_info list)
- : (toplevel_c_info * string) list =
- (List.concat (ccs +> List.map (fun x ->
- x.asts +> List.map (fun x' ->
- (x', x.fname)))))
-
-let for_unparser xs =
- xs +> List.map (fun x ->
- (x.ast_c, (x.fullstring, x.tokens_c)), Unparse_c.PPviastr
- )
-
-let gen_pdf_graph () =
- (Ctl_engine.get_graph_files ()) +> List.iter (fun outfile ->
- Printf.printf "Generation of %s%!" outfile;
- let filename_stack = Ctl_engine.get_graph_comp_files outfile in
- List.iter (fun filename ->
- ignore (Unix.system ("dot " ^ filename ^ " -Tpdf -o " ^ filename ^ ".pdf;"))
- ) filename_stack;
- let (head,tail) = (List.hd filename_stack, List.tl filename_stack) in
- ignore(Unix.system ("cp " ^ head ^ ".pdf " ^ outfile ^ ".pdf;"));
- tail +> List.iter (fun filename ->
- ignore(Unix.system ("mv " ^ outfile ^ ".pdf /tmp/tmp.pdf;"));
- ignore(Unix.system ("pdftk " ^ filename ^ ".pdf /tmp/tmp.pdf cat output " ^ outfile ^ ".pdf"));
- );
- ignore(Unix.system ("rm /tmp/tmp.pdf;"));
- List.iter (fun filename ->
- ignore (Unix.system ("rm " ^ filename ^ " " ^ filename ^ ".pdf;"))
- ) filename_stack;
- Printf.printf " - Done\n")
-
-
-(* --------------------------------------------------------------------- *)
-let prepare_cocci ctls free_var_lists negated_pos_lists
- used_after_lists positions_list metavars astcocci =
-
- let gathered = Common.index_list_1
- (zip (zip (zip (zip (zip (zip ctls metavars) astcocci) free_var_lists)
- negated_pos_lists) used_after_lists) positions_list)
- in
- gathered +> List.map
- (fun (((((((ctl_toplevel_list,metavars),ast),free_var_list),
- negated_pos_list),used_after_list),positions_list),rulenb) ->
-
- let is_script_rule r =
- match r with Ast_cocci.ScriptRule _ -> true | _ -> false in
-
- if not (List.length ctl_toplevel_list = 1) && not (is_script_rule ast)
- then failwith "not handling multiple minirules";
-
- match ast with
- Ast_cocci.ScriptRule (lang,deps,mv,code) ->
- let r =
- {
- scr_ast_rule = (lang, mv, code);
- language = lang;
- scr_dependencies = deps;
- scr_ruleid = rulenb;
- script_code = code;
- }
- in ScriptRuleCocciInfo r
- | Ast_cocci.CocciRule
- (rulename,(dependencies,dropped_isos,z),restast,isexp,ruletype) ->
- CocciRuleCocciInfo (
- {
- ctl = List.hd ctl_toplevel_list;
- metavars = metavars;
- ast_rule = ast;
- isexp = List.hd isexp;
- rulename = rulename;
- dependencies = dependencies;
- dropped_isos = dropped_isos;
- free_vars = List.hd free_var_list;
- negated_pos_vars = List.hd negated_pos_list;
- used_after = List.hd used_after_list;
- positions = List.hd positions_list;
- ruleid = rulenb;
- ruletype = ruletype;
- was_matched = ref false;
- })
- )
-
-
-(* --------------------------------------------------------------------- *)
-
-let build_info_program cprogram env =
- let (cs, parseinfos) = Common.unzip cprogram in
- let (cs, envs) =
- Common.unzip (TAC.annotate_program env (*!g_contain_typedmetavar*) cs) in
-
- zip (zip cs parseinfos) envs +> List.map (fun ((c, parseinfo), (enva,envb))->
- let (fullstr, tokens) = parseinfo in
-
- let flow =
- ast_to_flow_with_error_messages c +> Common.map_option (fun flow ->
- let flow = Ast_to_flow.annotate_loop_nodes flow in
-
- (* remove the fake nodes for julia *)
- let fixed_flow = CCI.fix_flow_ctl flow in
-
- if !Flag_cocci.show_flow then print_flow fixed_flow;
- if !Flag_cocci.show_before_fixed_flow then print_flow flow;
-
- fixed_flow
- )
- in
-
- {
- ast_c = c; (* contain refs so can be modified *)
- tokens_c = tokens;
- fullstring = fullstr;
-
- flow = flow;
-
- contain_loop = contain_loop flow;
-
- env_typing_before = enva;
- env_typing_after = envb;
-
- was_modified = ref false;
- }
- )
-
-
-
-(* Optimisation. Try not unparse/reparse the whole file when have modifs *)
-let rebuild_info_program cs file isexp =
- cs +> List.map (fun c ->
- if !(c.was_modified)
- then
- let file = Common.new_temp_file "cocci_small_output" ".c" in
- cfile_of_program
- [(c.ast_c, (c.fullstring, c.tokens_c)), Unparse_c.PPnormal]
- file;
-
- (* Common.command2 ("cat " ^ file); *)
- let cprogram = cprogram_of_file file in
- let xs = build_info_program cprogram c.env_typing_before in
-
- (* TODO: assert env has not changed,
- * if yes then must also reparse what follows even if not modified.
- * Do that only if contain_typedmetavar of course, so good opti.
- *)
- (* Common.list_init xs *) (* get rid of the FinalDef *)
- xs
- else [c]
- ) +> List.concat
-
-
-let rebuild_info_c_and_headers ccs isexp =
- ccs +> List.iter (fun c_or_h ->
- if c_or_h.asts +> List.exists (fun c -> !(c.was_modified))
- then c_or_h.was_modified_once := true;
- );
- ccs +> List.map (fun c_or_h ->
- { c_or_h with
- asts = rebuild_info_program c_or_h.asts c_or_h.full_fname isexp }
- )
-
-
-
-
-
-
-
-let prepare_c files choose_includes : file_info list =
- let cprograms = List.map cprogram_of_file_cached files in
- let includes = includes_to_parse (zip files cprograms) choose_includes in
-
- (* todo?: may not be good to first have all the headers and then all the c *)
- let all =
- (includes +> List.map (fun hpath -> Right hpath))
- ++
- ((zip files cprograms) +> List.map (fun (file, asts) -> Left (file, asts)))
- in
-
- let env = ref !TAC.initial_env in
-
- let ccs = all +> Common.map_filter (fun x ->
- match x with
- | Right hpath ->
- if not (Common.lfile_exists hpath)
- then begin
- pr2 ("TYPE: header " ^ hpath ^ " not found");
- None
- end
- else
- let h_cs = cprogram_of_file_cached hpath in
- let info_h_cs = build_info_program h_cs !env in
- env :=
- if null info_h_cs
- then !env
- else last_env_toplevel_c_info info_h_cs
- ;
- Some {
- fname = Common.basename hpath;
- full_fname = hpath;
- asts = info_h_cs;
- was_modified_once = ref false;
- fpath = hpath;
- fkind = Header;
- }
- | Left (file, cprogram) ->
- (* todo?: don't update env ? *)
- let cs = build_info_program cprogram !env in
- (* we do that only for the c, not for the h *)
- ignore(update_include_rel_pos (cs +> List.map (fun x -> x.ast_c)));
- Some {
- fname = Common.basename file;
- full_fname = file;
- asts = cs;
- was_modified_once = ref false;
- fpath = file;
- fkind = Source;
- }
- )
- in
- ccs
-
-
-(*****************************************************************************)
-(* Processing the ctls and toplevel C elements *)
-(*****************************************************************************)
-
-(* The main algorithm =~
- * The algorithm is roughly:
- * for_all ctl rules in SP
- * for_all minirule in rule (no more)
- * for_all binding (computed during previous phase)
- * for_all C elements
- * match control flow of function vs minirule
- * with the binding and update the set of possible
- * bindings, and returned the possibly modified function.
- * pretty print modified C elements and reparse it.
- *
- *
- * On ne prends que les newbinding ou returned_any_state est vrai.
- * Si ca ne donne rien, on prends ce qu'il y avait au depart.
- * Mais au nouveau depart de quoi ?
- * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
- * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
- * avec tous les bindings du round d'avant ?
- *
- * Julia pense qu'il faut prendre la premiere solution.
- * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
- * la regle ctl 1. On arrive sur la regle ctl 2.
- * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
- * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
- * la regle 3.
- *
- * I have not to look at used_after_list to decide to restart from
- * scratch. I just need to look if the binding list is empty.
- * Indeed, let's suppose that a SP have 3 regions/rules. If we
- * don't find a match for the first region, then if this first
- * region does not bind metavariable used after, that is if
- * used_after_list is empty, then mysat(), even if does not find a
- * match, will return a Left, with an empty transformation_info,
- * and so current_binding will grow. On the contrary if the first
- * region must bind some metavariables used after, and that we
- * dont find any such region, then mysat() will returns lots of
- * Right, and current_binding will not grow, and so we will have
- * an empty list of binding, and we will catch such a case.
- *
- * opti: julia says that because the binding is
- * determined by the used_after_list, the items in the list
- * are kind of sorted, so could optimise the insert_set operations.
- *)
-
-
-(* r(ule), c(element in C code), e(nvironment) *)
-
-let rec apply_python_rule r cache newes e rules_that_have_matched
- rules_that_have_ever_matched =
- show_or_not_scr_rule_name r.scr_ruleid;
- if not(interpret_dependencies rules_that_have_matched
- !rules_that_have_ever_matched r.scr_dependencies)
- then
- begin
- print_dependencies "dependencies for script not satisfied:"
- rules_that_have_matched
- !rules_that_have_ever_matched r.scr_dependencies;
- show_or_not_binding "in environment" e;
- (cache, (e, rules_that_have_matched)::newes)
- end
- else
- begin
- let (_, mv, _) = r.scr_ast_rule in
- if List.for_all (Pycocci.contains_binding e) mv
- then
- begin
- let relevant_bindings =
- List.filter
- (function ((re,rm),_) ->
- List.exists (function (_,(r,m)) -> r = re && m = rm) mv)
- e in
- let new_cache =
- if List.mem relevant_bindings cache
- then cache
- else
- begin
- print_dependencies "dependencies for script satisfied:"
- rules_that_have_matched
- !rules_that_have_ever_matched r.scr_dependencies;
- show_or_not_binding "in" e;
- Pycocci.build_classes (List.map (function (x,y) -> x) e);
- Pycocci.construct_variables mv e;
- let _ = Pycocci.pyrun_simplestring
- ("import coccinelle\nfrom coccinelle "^
- "import *\ncocci = Cocci()\n" ^
- r.script_code) in
- relevant_bindings :: cache
- end in
- if !Pycocci.inc_match
- then (new_cache, merge_env [(e, rules_that_have_matched)] newes)
- else (new_cache, newes)
- end
- else (cache, merge_env [(e, rules_that_have_matched)] newes)
- end
-
-and apply_cocci_rule r rules_that_have_ever_matched es (ccs:file_info list ref) =
- Common.profile_code r.rulename (fun () ->
- show_or_not_rule_name r.ast_rule r.ruleid;
- show_or_not_ctl_text r.ctl r.ast_rule r.ruleid;
-
- let reorganized_env =
- reassociate_positions r.free_vars r.negated_pos_vars !es in
-
- (* looping over the environments *)
- let (_,newes (* envs for next round/rule *)) =
- List.fold_left
- (function (cache,newes) ->
- function ((e,rules_that_have_matched),relevant_bindings) ->
- if not(interpret_dependencies rules_that_have_matched
- !rules_that_have_ever_matched r.dependencies)
- then
- begin
- print_dependencies
- ("dependencies for rule "^r.rulename^" not satisfied:")
- rules_that_have_matched
- !rules_that_have_ever_matched r.dependencies;
- show_or_not_binding "in environment" e;
- (cache,
- merge_env
- [(e +> List.filter (fun (s,v) -> List.mem s r.used_after),
- rules_that_have_matched)]
- newes)
- end
- else
- let new_bindings =
- try List.assoc relevant_bindings cache
- with
- Not_found ->
- print_dependencies
- ("dependencies for rule "^r.rulename^" satisfied:")
- rules_that_have_matched
- !rules_that_have_ever_matched r.dependencies;
- show_or_not_binding "in" e;
- show_or_not_binding "relevant in" relevant_bindings;
-
- (* applying the rule *)
- (match r.ruletype with
- Ast_cocci.Normal ->
- let children_e = ref [] in
-
- (* looping over the functions and toplevel elements in
- .c and .h *)
- concat_headers_and_c !ccs +> List.iter (fun (c,f) ->
- if c.flow <> None
- then
- (* does also some side effects on c and r *)
- let processed =
- process_a_ctl_a_env_a_toplevel r
- relevant_bindings c f in
- match processed with
- | None -> ()
- | Some newbindings ->
- newbindings +> List.iter (fun newbinding ->
- children_e :=
- Common.insert_set newbinding !children_e)
- ); (* end iter cs *)
-
- !children_e
- | Ast_cocci.Generated ->
- process_a_generated_a_env_a_toplevel r
- relevant_bindings !ccs;
- []) in
-
- let old_bindings_to_keep =
- Common.nub
- (e +> List.filter (fun (s,v) -> List.mem s r.used_after)) in
- let new_e =
- if null new_bindings
- then
- begin
- (*use the old bindings, specialized to the used_after_list*)
- if !Flag_ctl.partial_match
- then
- printf
- "Empty list of bindings, I will restart from old env";
- [(old_bindings_to_keep,rules_that_have_matched)]
- end
- else
- (* combine the new bindings with the old ones, and
- specialize to the used_after_list *)
- let old_variables = List.map fst old_bindings_to_keep in
- (* have to explicitly discard the inherited variables
- because we want the inherited value of the positions
- variables not the extended one created by
- reassociate_positions. want to reassociate freshly
- according to the free variables of each rule. *)
- let new_bindings_to_add =
- Common.nub
- (new_bindings +>
- List.map
- (List.filter
- (fun (s,v) ->
- List.mem s r.used_after &&
- not (List.mem s old_variables)))) in
- List.map
- (function new_binding_to_add ->
- (List.sort compare
- (Common.union_set
- old_bindings_to_keep new_binding_to_add),
- r.rulename::rules_that_have_matched))
- new_bindings_to_add in
- ((relevant_bindings,new_bindings)::cache,
- merge_env new_e newes))
- ([],[]) reorganized_env in (* end iter es *)
- if !(r.was_matched)
- then Common.push2 r.rulename rules_that_have_ever_matched;
-
- es := newes;
-
- (* apply the tagged modifs and reparse *)
- if not !Flag.sgrep_mode2
- then ccs := rebuild_info_c_and_headers !ccs r.isexp
- )
-
-and merge_env new_e old_e =
- List.fold_left
- (function old_e ->
- function (e,rules) as elem ->
- let (same,diff) = List.partition (function (e1,_) -> e = e1) old_e in
- match same with
- [] -> elem :: old_e
- | [(_,old_rules)] -> (e,Common.union_set rules old_rules) :: diff
- | _ -> failwith "duplicate environment entries")
- old_e new_e
-
-and bigloop2 rs (ccs: file_info list) =
- let es = ref [(Ast_c.emptyMetavarsBinding,[])] in
- let ccs = ref ccs in
- let rules_that_have_ever_matched = ref [] in
-
- (* looping over the rules *)
- rs +> List.iter (fun r ->
- match r with
- ScriptRuleCocciInfo r ->
- if !Flag_cocci.show_ctl_text then begin
- Common.pr_xxxxxxxxxxxxxxxxx ();
- pr ("script: " ^ r.language);
- Common.pr_xxxxxxxxxxxxxxxxx ();
-
- adjust_pp_with_indent (fun () ->
- Format.force_newline();
- let (l,mv,code) = r.scr_ast_rule in
- let deps = r.scr_dependencies in
- Pretty_print_cocci.unparse
- (Ast_cocci.ScriptRule (l,deps,mv,code)));
- end;
-
- if !Flag.show_misc then print_endline "RESULT =";
-
- let (_, newes) =
- List.fold_left
- (function (cache, newes) ->
- function (e, rules_that_have_matched) ->
- match r.language with
- "python" ->
- apply_python_rule r cache newes e rules_that_have_matched
- rules_that_have_ever_matched
- | "test" ->
- concat_headers_and_c !ccs +> List.iter (fun (c,_) ->
- if c.flow <> None
- then
- Printf.printf "Flow: %s\r\nFlow!\r\n%!" c.fullstring);
- (cache, newes)
- | _ ->
- Printf.printf "Unknown language: %s\n" r.language;
- (cache, newes)
- )
- ([],[]) !es in
-
- es := newes;
- | CocciRuleCocciInfo r ->
- apply_cocci_rule r rules_that_have_ever_matched es ccs);
-
- if !Flag.sgrep_mode2
- then begin
- (* sgrep can lead to code that is not parsable, but we must
- * still call rebuild_info_c_and_headers to pretty print the
- * action (MINUS), so that later the diff will show what was
- * matched by sgrep. But we don't want the parsing error message
- * hence the following flag setting. So this code propably
- * will generate a NotParsedCorrectly for the matched parts
- * and the very final pretty print and diff will work
- *)
- Flag_parsing_c.verbose_parsing := false;
- ccs := rebuild_info_c_and_headers !ccs false
- end;
- !ccs (* return final C asts *)
-
-and reassociate_positions free_vars negated_pos_vars envs =
- (* issues: isolate the bindings that are relevant to a given rule.
- separate out the position variables
- associate all of the position variables for a given set of relevant
- normal variable bindings with each set of relevant normal variable
- bindings. Goal: if eg if@p (E) matches in two places, then both inherited
- occurrences of E should see both bindings of p, not just its own.
- Otherwise, a position constraint for something that matches in two
- places will never be useful, because the position can always be
- different from the other one. *)
- let relevant =
- List.map
- (function (e,_) ->
- List.filter (function (x,_) -> List.mem x free_vars) e)
- envs in
- let splitted_relevant =
- (* separate the relevant variables into the non-position ones and the
- position ones *)
- List.map
- (function r ->
- List.fold_left
- (function (non_pos,pos) ->
- function (v,_) as x ->
- if List.mem v negated_pos_vars
- then (non_pos,x::pos)
- else (x::non_pos,pos))
- ([],[]) r)
- relevant in
- let splitted_relevant =
- List.map
- (function (non_pos,pos) ->
- (List.sort compare non_pos,List.sort compare pos))
- splitted_relevant in
- let non_poss =
- List.fold_left
- (function non_pos ->
- function (np,_) ->
- if List.mem np non_pos then non_pos else np::non_pos)
- [] splitted_relevant in
- let extended_relevant =
- (* extend the position variables with the values found at other identical
- variable bindings *)
- List.map
- (function non_pos ->
- let others =
- List.filter
- (function (other_non_pos,other_pos) ->
- (* do we want equal? or just somehow compatible? eg non_pos
- binds only E, but other_non_pos binds both E and E1 *)
- non_pos = other_non_pos)
- splitted_relevant in
- (non_pos,
- List.sort compare
- (non_pos @
- (combine_pos negated_pos_vars
- (List.map (function (_,x) -> x) others)))))
- non_poss in
- List.combine envs
- (List.map (function (non_pos,_) -> List.assoc non_pos extended_relevant)
- splitted_relevant)
-
-and combine_pos negated_pos_vars others =
- List.map
- (function posvar ->
- (posvar,
- Ast_c.MetaPosValList
- (List.sort compare
- (List.fold_left
- (function positions ->
- function other_list ->
- try
- match List.assoc posvar other_list with
- Ast_c.MetaPosValList l1 ->
- Common.union_set l1 positions
- | _ -> failwith "bad value for a position variable"
- with Not_found -> positions)
- [] others))))
- negated_pos_vars
-
-and bigloop a b =
- Common.profile_code "bigloop" (fun () -> bigloop2 a b)
-
-
-
-
-
-(* does side effects on C ast and on Cocci info rule *)
-and process_a_ctl_a_env_a_toplevel2 r e c f =
- indent_do (fun () ->
- show_or_not_celem "trying" c.ast_c;
- Flag.currentfile := Some (f ^ ":" ^get_celem c.ast_c);
- let (trans_info, returned_any_states, inherited_bindings, newbindings) =
- Common.save_excursion Flag_ctl.loop_in_src_code (fun () ->
- Flag_ctl.loop_in_src_code := !Flag_ctl.loop_in_src_code||c.contain_loop;
-
- (***************************************)
- (* !Main point! The call to the engine *)
- (***************************************)
- let model_ctl = CCI.model_for_ctl r.dropped_isos (Common.some c.flow) e
- in CCI.mysat model_ctl r.ctl (r.used_after, e)
- )
- in
- if not returned_any_states
- then None
- else begin
- show_or_not_celem "found match in" c.ast_c;
- show_or_not_trans_info trans_info;
- List.iter (show_or_not_binding "out") newbindings;
-
- r.was_matched := true;
-
- if not (null trans_info)
- then begin
- c.was_modified := true;
- try
- (* les "more than one var in a decl" et "already tagged token"
- * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
- * failed. Le try limite le scope des crashes pendant la
- * trasformation au fichier concerne. *)
-
- (* modify ast via side effect *)
- ignore(Transformation_c.transform r.rulename r.dropped_isos
- inherited_bindings trans_info (Common.some c.flow));
- with Timeout -> raise Timeout | UnixExit i -> raise (UnixExit i)
- end;
-
- Some (List.map (function x -> x@inherited_bindings) newbindings)
- end
- )
-
-and process_a_ctl_a_env_a_toplevel a b c f=
- Common.profile_code "process_a_ctl_a_env_a_toplevel"
- (fun () -> process_a_ctl_a_env_a_toplevel2 a b c f)
-
-and process_a_generated_a_env_a_toplevel2 r env = function
- [cfile] ->
- let free_vars =
- List.filter
- (function
- (rule,_) when rule = r.rulename -> false
- | (_,"ARGS") -> false
- | _ -> true)
- r.free_vars in
- let env_domain = List.map (function (nm,vl) -> nm) env in
- let metavars =
- List.filter
- (function md ->
- let (rl,_) = Ast_cocci.get_meta_name md in
- rl = r.rulename)
- r.metavars in
- if Common.include_set free_vars env_domain
- then Unparse_hrule.pp_rule metavars r.ast_rule env cfile.full_fname
- | _ -> failwith "multiple files not supported"
-
-and process_a_generated_a_env_a_toplevel rule env ccs =
- Common.profile_code "process_a_ctl_a_env_a_toplevel"
- (fun () -> process_a_generated_a_env_a_toplevel2 rule env ccs)
-
-
-
-(*****************************************************************************)
-(* The main function *)
-(*****************************************************************************)
-
-let full_engine2 (coccifile, isofile) cfiles =
-
- show_or_not_cfiles cfiles;
- show_or_not_cocci coccifile isofile;
- Pycocci.set_coccifile coccifile;
-
- let isofile =
- if not (Common.lfile_exists isofile)
- then begin
- pr2 ("warning: Can't find default iso file: " ^ isofile);
- None
- end
- else Some isofile
- in
-
- (* useful opti when use -dir *)
- let (metavars,astcocci,free_var_lists,negated_pos_lists,used_after_lists,
- positions_lists,toks,_) =
- sp_of_file coccifile isofile
- in
- let ctls =
- Common.memoized _hctl (coccifile, isofile) (fun () ->
- ctls_of_ast astcocci used_after_lists positions_lists)
- in
-
- let contain_typedmetavar = sp_contain_typed_metavar astcocci in
-
- (* optimisation allowing to launch coccinelle on all the drivers *)
- if !Flag_cocci.worth_trying_opt && not (worth_trying cfiles toks)
- then begin
- pr2 ("not worth trying:" ^ Common.join " " cfiles);
- cfiles +> List.map (fun s -> s, None)
- end
- else begin
-
- if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx();
- if !Flag.show_misc then pr "let's go";
- if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx();
-
- g_contain_typedmetavar := contain_typedmetavar;
-
- check_macro_in_sp_and_adjust toks;
-
-
-
- let cocci_infos =
- prepare_cocci ctls free_var_lists negated_pos_lists
- used_after_lists positions_lists metavars astcocci in
- let choose_includes =
- match !Flag_cocci.include_options with
- Flag_cocci.I_UNSPECIFIED ->
- if contain_typedmetavar
- then Flag_cocci.I_NORMAL_INCLUDES
- else Flag_cocci.I_NO_INCLUDES
- | x -> x in
- let c_infos = prepare_c cfiles choose_includes in
-
- show_or_not_ctl_tex astcocci ctls;
-
- (* ! the big loop ! *)
- let c_infos' = bigloop cocci_infos c_infos in
-
- if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx ();
- if !Flag.show_misc then pr "Finished";
- if !Flag_ctl.graphical_trace then gen_pdf_graph ();
- if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx();
-
- c_infos' +> List.map (fun c_or_h ->
- if !(c_or_h.was_modified_once)
- then begin
- let outfile = Common.new_temp_file "cocci-output" ("-" ^ c_or_h.fname)
- in
-
- if c_or_h.fkind = Header
- then pr2 ("a header file was modified: " ^ c_or_h.fname);
-
- (* and now unparse everything *)
- cfile_of_program (for_unparser c_or_h.asts) outfile;
-
- let show_only_minus = !Flag.sgrep_mode2 in
- show_or_not_diff c_or_h.fpath outfile show_only_minus;
-
- (c_or_h.fpath,
- if !Flag.sgrep_mode2 then None else Some outfile
- )
- end
- else
- (c_or_h.fpath, None)
- );
- end
-
-let full_engine a b =
- Common.profile_code "full_engine" (fun () -> full_engine2 a b)
-
-
-(*****************************************************************************)
-(* check duplicate from result of full_engine *)
-(*****************************************************************************)
-
-let check_duplicate_modif2 xs =
- (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
- pr2 ("Check duplication for " ^ i_to_s (List.length xs) ^ " files");
- let groups = Common.group_assoc_bykey_eff xs in
- groups +> Common.map_filter (fun (file, xs) ->
- match xs with
- | [] -> raise Impossible
- | [res] -> Some (file, res)
- | res::xs ->
- match res with
- | None ->
- if not (List.for_all (fun res2 -> res2 = None) xs)
- then begin
- pr2 ("different modification result for " ^ file);
- None
- end
- else Some (file, None)
- | Some res ->
- if not(List.for_all (fun res2 ->
- match res2 with
- | None -> false
- | Some res2 ->
- let diff = Common.cmd_to_list ("diff -u -b -B "^res^" "^res2)
- in
- null diff
- ) xs) then begin
- pr2 ("different modification result for " ^ file);
- None
- end
- else Some (file, Some res)
-
-
- )
-let check_duplicate_modif a =
- Common.profile_code "check_duplicate" (fun () -> check_duplicate_modif2 a)
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-module FC = Flag_cocci
-
-(*****************************************************************************)
-(* Flags *)
-(*****************************************************************************)
-
-(* In addition to flags that can be tweaked via -xxx options (cf the
- * full list of options in "the spatch options" section below), the
- * spatch program also depends on external files, described in
- * globals/config.ml, mainly a standard.h and standard.iso file *)
-
-let cocci_file = ref ""
-
-let output_file = ref ""
-let inplace_modif = ref false (* but keeps a .cocci_orig *)
-let outplace_modif = ref false (* generates a .cocci_res *)
-
-(* could be avoided by using Common.files_of_dir_or_files instead *)
-let dir = ref false
-
-let include_headers = ref false
-let kbuild_info = ref ""
-
-(* test mode *)
-let test_mode = ref false
-let test_all = ref false
-let test_okfailed = ref false
-let test_regression_okfailed = ref false
-
-
-(* action mode *)
-let action = ref ""
-
-(* works with -test but also in "normal" spatch mode *)
-let compare_with_expected = ref false
-
-
-let distrib_index = ref (None : int option)
-let distrib_max = ref (None : int option)
-let mod_distrib = ref false
-
-
-(*****************************************************************************)
-(* Profiles *)
-(*****************************************************************************)
-
-(* pair of (list of flags to set true, list of flags to set false *)
-let quiet_profile = (
- [
- ],
- [
- (* FC.show_diff; just leave this as it is *)
-
- Flag.show_misc;
- Flag.show_trying;
- Flag.show_transinfo;
-
- FC.show_c;
- FC.show_cocci;
- FC.show_flow;
- FC.show_before_fixed_flow;
- FC.show_ctl_tex;
- FC.show_ctl_text;
- FC.show_binding_in_out;
-
- Flag_parsing_cocci.show_SP;
- Flag_parsing_cocci.show_iso_failures;
- Flag_ctl.verbose_ctl_engine;
- Flag_ctl.verbose_match;
- Flag_matcher.debug_engine;
- Flag_parsing_c.debug_unparsing;
- Flag_parsing_c.verbose_type;
- Flag_parsing_c.verbose_parsing;
- ])
-
-(* some information that is useful in seeing why a semantic patch doesn't
-work properly *)
-let debug_profile = (
- [
- Flag.show_misc;
- FC.show_diff;
- FC.show_cocci;
- FC.show_binding_in_out;
- FC.show_dependencies;
- Flag.show_transinfo;
- Flag_parsing_cocci.show_iso_failures;
- ],
- [
-
- Flag.show_misc;
-
- FC.show_c;
- FC.show_flow;
- FC.show_before_fixed_flow;
- FC.show_ctl_tex;
- FC.show_ctl_text;
-
- Flag_parsing_cocci.show_SP;
- Flag_ctl.verbose_ctl_engine;
- Flag_ctl.verbose_match;
- Flag_matcher.debug_engine;
- Flag_parsing_c.debug_unparsing;
- Flag_parsing_c.verbose_type;
- Flag_parsing_c.verbose_parsing;
- ])
-
-let pad_profile = (
- [
- FC.show_diff;
- ],
- [
-
- Flag.show_misc;
- Flag.show_transinfo;
-
- FC.show_c;
- FC.show_cocci;
- FC.show_flow;
- FC.show_before_fixed_flow;
- FC.show_ctl_tex;
- FC.show_ctl_text;
- FC.show_binding_in_out;
-
- Flag_parsing_cocci.show_SP;
- Flag_parsing_cocci.show_iso_failures;
- Flag_ctl.verbose_ctl_engine;
- Flag_ctl.verbose_match;
- Flag_matcher.debug_engine;
- Flag_parsing_c.debug_unparsing;
- Flag_parsing_c.verbose_type;
- Flag_parsing_c.verbose_parsing;
- ])
-
-let run_profile p =
- let (set_to_true, set_to_false) = p in
- List.iter (fun x -> x := false) set_to_false;
- List.iter (fun x -> x := true) set_to_true
-
-(*****************************************************************************)
-(* The spatch options *)
-(*****************************************************************************)
-
-let usage_msg =
- "Usage: " ^ basename Sys.argv.(0) ^
- " -sp_file <SP> <infile> [-o <outfile>] [-iso_file <iso>] [options]" ^
- "\n" ^ "Options are:"
-
-(* forward reference trick *)
-let short_usage_func = ref (fun () -> ())
-let long_usage_func = ref (fun () -> ())
-
-
-(* The short_options are user-oriented. The other options are for
- * the developers of coccinelle or advanced-users that know
- * quite well the underlying semantics of coccinelle.
- *)
-
-
-(* will be printed when use only ./spatch. For the rest you have to
- * use -longhelp to see them.
- *)
-let short_options = [
- "-sp_file", Arg.Set_string cocci_file,
- " <file> the semantic patch file";
-
- "-o", Arg.Set_string output_file,
- " <file> the output file";
- "-inplace", Arg.Set inplace_modif,
- " do the modification on the file directly";
- "-outplace", Arg.Set outplace_modif,
- " store modifications in a .cocci_res file";
-
- "-U", Arg.Int (fun n -> Flag_parsing_c.diff_lines := Some (i_to_s n)),
- " set number of diff context lines";
- "-partial_match", Arg.Set Flag_ctl.partial_match,
- " report partial matches of the SP on the C file";
-
- "-iso_file", Arg.Set_string Config.std_iso,
- " <file> (default=" ^ !Config.std_iso ^")";
- "-macro_file", Arg.Set_string Config.std_h,
- " <file> (default=" ^ !Config.std_h ^ ")";
-
- "-all_includes",
- Arg.Unit (function _ -> FC.include_options := FC.I_ALL_INCLUDES),
- " causes all available include files to be used";
- "-no_includes",
- Arg.Unit (function _ -> FC.include_options := FC.I_NO_INCLUDES),
- " causes not even local include files to be used";
- "-local_includes",
- Arg.Unit (function _ -> FC.include_options := FC.I_NORMAL_INCLUDES),
- " causes local include files to be used";
- "-include_headers", Arg.Set include_headers,
- " process header files independently";
- "-I", Arg.Set_string FC.include_path,
- " <dir> containing the Linux headers (optional)";
-
-
- "-dir", Arg.Set dir,
- " <dir> process all files in directory recursively";
-
- "-use_glimpse", Arg.Set Flag.use_glimpse,
- " works with -dir, use info generated by glimpseindex";
- "-patch", Arg.String (function s -> Flag.patch := Some s),
- (" <dir> path name with respect to which a patch should be created\n"^
- " \"\" for a file in the current directory");
- "-kbuild_info", Arg.Set_string kbuild_info,
- " <file> improve -dir by grouping related c files";
- "-pyoutput", Arg.Set_string Flag.pyoutput,
- " Sets output routine: Standard values: <coccilib.output.Gtk|coccilib.output.Console>";
-
-
- "-version", Arg.Unit (fun () ->
- pr2 (spf "spatch version: %s" Config.version);
- exit 0;
- ),
- " guess what";
-
- "-date", Arg.Unit (fun () ->
- pr2 "version: $Date: 2009/01/02 10:28:28 $";
- raise (Common.UnixExit 0)
- ),
- " guess what";
-
- "-shorthelp", Arg.Unit (fun () ->
- !short_usage_func();
- raise (Common.UnixExit 0)
- ),
- " see short list of options";
- "-longhelp", Arg.Unit (fun () ->
- !long_usage_func();
- raise (Common.UnixExit 0)
- ),
- " see all the available options in different categories";
- "-help", Arg.Unit (fun () ->
- !long_usage_func();
- raise (Common.UnixExit 0)
- ),
- " ";
- "--help", Arg.Unit (fun () ->
- !long_usage_func();
- raise (Common.UnixExit 0)
- ),
- " ";
-
-]
-
-(* the format is a list of triples:
- * (title of section * (optional) explanation of sections * option list)
- *)
-let other_options = [
- "aliases and obsolete options",
- "",
- [
- "-cocci_file", Arg.Set_string cocci_file,
- " <file> the semantic patch file";
- "-c", Arg.Set_string cocci_file, " short option of -cocci_file";
- "-iso", Arg.Set_string Config.std_iso, " short option of -iso_file";
- "-D", Arg.Set_string Config.std_h, " short option of -macro_file";
- ];
-
- "most useful show options",
- "",
- [
- "-show_diff" , Arg.Set FC.show_diff, " ";
- "-no_show_diff" , Arg.Clear FC.show_diff, " ";
- "-show_flow" , Arg.Set FC.show_flow, " ";
- (* works in conjunction with -show_ctl_text *)
- "-ctl_inline_let",
- Arg.Unit
- (function _ -> FC.show_ctl_text := true; FC.inline_let_ctl := true), " ";
- "-ctl_show_mcodekind",
- Arg.Unit
- (function _ -> FC.show_ctl_text := true; FC.show_mcodekind_in_ctl := true),
- " ";
- "-show_bindings", Arg.Set FC.show_binding_in_out, " ";
- "-show_transinfo", Arg.Set Flag.show_transinfo, " ";
- "-show_misc", Arg.Set Flag.show_misc, " ";
- "-show_trying", Arg.Set Flag.show_trying,
- " show the name of each function being processed";
- "-show_dependencies",
- Arg.Unit (function _ -> FC.show_dependencies := true;
- FC.show_binding_in_out := true),
- " show the dependencies related to each rule";
- ];
-
- "verbose subsystems options",
- "",
- [
- "-verbose_ctl_engine",
- Arg.Unit (function _ ->
- Flag_ctl.verbose_ctl_engine := true; FC.show_ctl_text := true) , " ";
- "-verbose_match", Arg.Set Flag_ctl.verbose_match, " ";
- "-verbose_engine", Arg.Set Flag_matcher.debug_engine, " ";
- "-graphical_trace", Arg.Set Flag_ctl.graphical_trace, " generate a pdf file representing the matching process";
- "-gt_without_label",
- Arg.Unit (function _ ->
- Flag_ctl.graphical_trace := true; Flag_ctl.gt_without_label := true),
- " remove graph label (requires option -graphical_trace)";
-
- "-parse_error_msg", Arg.Set Flag_parsing_c.verbose_parsing, " ";
- "-type_error_msg", Arg.Set Flag_parsing_c.verbose_type, " ";
- (* could also use Flag_parsing_c.options_verbose *)
- ];
-
- "other show options",
- "",
- [
- "-show_c" , Arg.Set FC.show_c, " ";
- "-show_cocci" , Arg.Set FC.show_cocci, " ";
- "-show_before_fixed_flow" , Arg.Set FC.show_before_fixed_flow, " ";
- "-show_ctl_tex" , Arg.Set FC.show_ctl_tex, " ";
- "-show_ctl_text" , Arg.Set FC.show_ctl_text, " ";
- "-show_SP" , Arg.Set Flag_parsing_cocci.show_SP, " ";
- ];
-
-
- "debug C parsing/unparsing",
- "",
- [
- "-debug_cpp", Arg.Set Flag_parsing_c.debug_cpp, " ";
- "-debug_lexer", Arg.Set Flag_parsing_c.debug_lexer , " ";
- "-debug_etdt", Arg.Set Flag_parsing_c.debug_etdt , " ";
- "-debug_typedef", Arg.Set Flag_parsing_c.debug_typedef, " ";
-
- "-filter_msg", Arg.Set Flag_parsing_c.filter_msg ,
- " filter some cpp message when the macro is a \"known\" cpp construct";
- "-filter_define_error",Arg.Set Flag_parsing_c.filter_define_error," ";
- "-filter_passed_level", Arg.Set_int Flag_parsing_c.filter_passed_level," ";
-(* debug cfg doesn't seem to have any effect, so drop it as an option *)
-(* "-debug_cfg", Arg.Set Flag_parsing_c.debug_cfg , " "; *)
- "-debug_unparsing", Arg.Set Flag_parsing_c.debug_unparsing, " ";
-
- ];
- (* could use Flag_parsing_c.options_debug_with_title instead *)
-
-
- "shortcut for enabling/disabling a set of debugging options at once",
- "",
- [
- (* todo: other profile ? *)
- "-quiet", Arg.Unit (fun () -> run_profile quiet_profile), " ";
- "-debug", Arg.Unit (fun () -> run_profile debug_profile), " ";
- "-pad", Arg.Unit (fun () -> run_profile pad_profile), " ";
-
- ];
-
- "bench options",
- "",
- [
- "-profile", Arg.Unit (function () -> Common.profile := Common.PALL) ,
- " gather timing information about the main coccinelle functions";
- "-bench", Arg.Int (function x -> Flag_ctl.bench := x),
- " <level> for profiling the CTL engine";
- "-timeout", Arg.Int (fun x -> FC.timeout := Some x),
- " <sec> timeout in seconds";
- "-steps", Arg.Int (fun x -> Flag_ctl.steps := Some x),
- " max number of model checking steps per code unit";
- "-track_iso", Arg.Set Flag.track_iso_usage,
- " gather information about isomorphism usage";
- "-profile_iso",
- Arg.Unit
- (function () ->
- Common.profile:=PSOME ["parse cocci";"mysat";"asttoctl2";"full_engine"]),
- " gather information about the cost of isomorphism usage"
- ];
-
-
-
- "change of algorithm options",
- "",
- [
- "-popl", Arg.Set FC.popl,
- " simplified SmPL, for the popl paper";
-
- "-popl_mark_all",
- Arg.Unit
- (function _ -> FC.popl := true; Flag_popl.mark_all := true),
- " simplified SmPL, for the popl paper";
-
- "-popl_keep_all_wits",
- Arg.Unit
- (function _ -> FC.popl := true; Flag_popl.keep_all_wits := true),
- " simplified SmPL, for the popl paper";
-
- "-hrule", Arg.String
- (function s ->
- Flag.make_hrule := Some s; FC.include_options := FC.I_NO_INCLUDES),
- " semantic patch generation";
-
- "-loop", Arg.Set Flag_ctl.loop_in_src_code, " ";
-
- "-l1", Arg.Clear Flag_parsing_c.label_strategy_2, " ";
- "-ifdef_to_if", Arg.Set FC.ifdef_to_if,
- " convert ifdef to if (experimental)";
-
- "-noif0_passing", Arg.Clear Flag_parsing_c.if0_passing,
- " ";
- "-noadd_typedef_root", Arg.Clear Flag_parsing_c.add_typedef_root, " ";
- (* could use Flag_parsing_c.options_algo instead *)
-
-
- "-disallow_nested_exps", Arg.Set Flag_matcher.disallow_nested_exps,
- "disallow an expresion pattern from matching a term and its subterm";
- "-disable_worth_trying_opt", Arg.Clear FC.worth_trying_opt,
- " ";
- "-only_return_is_error_exit",
- Arg.Set Flag_matcher.only_return_is_error_exit,
- "if this flag is not set, then break and continue are also error exits";
- (* the following is a hack to make it easier to add code in sgrep-like
- code, essentially to compensate for the fact that we don't have
- any way of printing things out *)
- "-allow_inconsistent_paths",
- Arg.Set Flag_matcher.allow_inconsistent_paths,
- "if this flag is set don't check for inconsistent paths; dangerous";
- ];
-
- "misc options",
- "",
- [
- "-debugger", Arg.Set Common.debugger ,
- " option to set if launch spatch in ocamldebug";
- "-disable_once", Arg.Set Common.disable_pr2_once,
- " to print more messages";
- "-save_tmp_files", Arg.Set Common.save_tmp_files, " ";
- ];
-
- "concurrency",
- "",
- [
- "-index", Arg.Int (function x -> distrib_index := Some x) ,
- " the processor to use for this run of spatch";
- "-max", Arg.Int (function x -> distrib_max := Some x) ,
- " the number of processors available";
- "-mod_distrib", Arg.Set mod_distrib,
- " use mod to distribute files among the processors";
- ];
-
- "pad options",
- "",
- [
- "-use_cache", Arg.Set Flag_parsing_c.use_cache,
- " use .ast_raw pre-parsed cached C file";
- (* could use Flag_parsing_c.options_pad instead *)
- ];
-
-
-
- "test mode and test options (works with tests/ or .ok files)",
- "The test options don't work with the -sp_file and so on.",
- [
- "-test", Arg.Set test_mode,
- " <file> launch spatch on tests/file.[c,cocci]";
- "-testall", Arg.Set test_all,
- " launch spatch on all files in tests/ having a .res";
- "-test_okfailed", Arg.Set test_okfailed,
- " generates .{ok,failed,spatch_ok} files using .res files";
- "-test_regression_okfailed", Arg.Set test_regression_okfailed,
- " process the .{ok,failed,spatch_ok} files in current dir";
-
- "-compare_with_expected", Arg.Set compare_with_expected,
- " use also file.res";
- "-relax_include_path", Arg.Set FC.relax_include_path,
- " ";
-
- ];
-
- "action mode",
- ("The action options don't work with the -sp_file and so on." ^ "\n" ^
- "It's for the other (internal) uses of the spatch program."
- ),
-
- (* -token_c, -parse_c, etc *)
- ((Common.options_of_actions action (Test_parsing_c.actions())) ++
- [
- (let s = "-parse_cocci" in s, Arg.Unit (fun () -> action := s),
- " <file>");
- (let s = "-compare_c" in s, Arg.Unit (fun () -> action := s),
- " <file1> <file2>");
- ]);
-]
-
-
-let all_options =
- short_options ++ List.concat (List.map Common.thd3 other_options)
-
-
-
-(* I don't want the -help and --help that are appended by Arg.align *)
-let arg_align2 xs =
- Arg.align xs +> List.rev +> Common.drop 2 +> List.rev
-
-(* copy paste of Arg.parse. Don't want the default -help msg *)
-let arg_parse2 l f msg =
- (try
- Arg.parse_argv Sys.argv l f msg;
- with
- | Arg.Bad msg -> (* eprintf "%s" msg; exit 2; *)
- let xs = Common.lines msg in
- (* take only head, it's where the error msg is *)
- pr2 (List.hd xs);
- !short_usage_func();
- raise (Common.UnixExit (2))
- | Arg.Help msg -> (* printf "%s" msg; exit 0; *)
- raise Impossible (* -help is specified in speclist *)
- )
-
-
-let short_usage () =
- begin
- Common.short_usage usage_msg short_options;
- pr2 "";
- pr2 "Example of use:";
- pr2 " ./spatch -sp_file foo.cocci foo.c -o /tmp/newfoo.c";
- pr2 "";
- end
-
-
-let long_usage () =
- Common.long_usage usage_msg short_options other_options
-
-let _ = short_usage_func := short_usage
-let _ = long_usage_func := long_usage
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-let adjust_stdin cfile k =
- if !dir
- then k()
- else
- let newin =
- try
- let (dir, base, ext) = Common.dbe_of_filename cfile in
- let varfile = Common.filename_of_dbe (dir, base, "var") in
- if ext = "c" && Common.lfile_exists varfile
- then Some varfile
- else None
- with Invalid_argument("Filename.chop_extension") -> None
- in
- Common.redirect_stdin_opt newin k
-
-let glimpse_filter (coccifile, isofile) dir =
- let (_metavars,astcocci,_free_var_lists,_negated_positions,
- _used_after_lists,_positions_lists,_,query) =
- Cocci.sp_of_file coccifile (Some isofile) in
- match query with
- None -> pr2 "no glimpse keyword inferred from snippet"; None
- | Some query ->
- let suffixes = if !include_headers then ["c";"h"] else ["c"] in
- pr2 ("glimpse request = " ^ query);
- let command = spf "glimpse -y -H %s -N -W -w '%s'" dir query in
- let (glimpse_res,stat) = Common.cmd_to_list_and_status command in
- match stat with
- Unix.WEXITED(0) | Unix.WEXITED(1) ->
- Some
- (glimpse_res +>
- List.filter
- (fun file -> List.mem (Common.filesuffix file) suffixes))
- | _ -> None (* error, eg due to pattern too big *)
-
-
-
-
-(*****************************************************************************)
-(* The coccinelle main entry point *)
-(*****************************************************************************)
-let main () =
- begin
- let args = ref [] in
-
- arg_parse2 (Arg.align all_options) (fun x -> args := x::!args) usage_msg;
-
- (if !dir && List.length !args > 1
- then
- begin
- let chosen = List.hd !args in
- pr2 ("ignoring all but the last specified directory: "^chosen);
- args := [chosen]
- end);
- args := List.rev !args;
-
- if !cocci_file <> "" && (not (!cocci_file =~ ".*\\.\\(sgrep\\|spatch\\)$"))
- then cocci_file := Common.adjust_ext_if_needed !cocci_file ".cocci";
-
- if !Config.std_iso <> ""
- then Config.std_iso := Common.adjust_ext_if_needed !Config.std_iso ".iso";
- if !Config.std_h <> ""
- then Config.std_h := Common.adjust_ext_if_needed !Config.std_h ".h";
-
- if !Config.std_h <> ""
- then Parse_c.init_defs !Config.std_h;
-
-
- (* must be done after Arg.parse, because Common.profile is set by it *)
- Common.profile_code "Main total" (fun () ->
-
-
- let all_actions = Test_parsing_c.actions() in
-
- (match (!args) with
-
- (* --------------------------------------------------------- *)
- (* The test framework. Works with tests/ or .ok and .failed *)
- (* --------------------------------------------------------- *)
- | [x] when !test_mode ->
- FC.include_path := "tests/include";
- Testing.testone x !compare_with_expected
-
- | [] when !test_all ->
- FC.include_path := "tests/include";
- Testing.testall ()
-
- | [] when !test_regression_okfailed ->
- Testing.test_regression_okfailed ()
-
- | x::xs when !test_okfailed ->
- (* do its own timeout on FC.timeout internally *)
- FC.relax_include_path := true;
- adjust_stdin x (fun () ->
- Testing.test_okfailed !cocci_file (x::xs)
- )
-
- (* --------------------------------------------------------- *)
- (* Actions, useful to debug subpart of coccinelle *)
- (* --------------------------------------------------------- *)
-
- | xs when List.mem !action (Common.action_list all_actions) ->
- Common.do_action !action xs all_actions
-
- | [file] when !action = "-parse_cocci" ->
- Testing.test_parse_cocci file
-
- (* I think this is used by some scripts in some Makefile for our
- * big-tests. So dont remove.
- *)
- | [file1;file2] when !action = "-compare_c" ->
- Test_parsing_c.test_compare_c file1 file2 (* result = unix code *)
-
- (* could add the Test_parsing_c.test_actions such as -parse_c & co *)
-
-
- (* --------------------------------------------------------- *)
- (* This is the main entry *)
- (* --------------------------------------------------------- *)
- | x::xs ->
- adjust_stdin x (fun () ->
- if !cocci_file = ""
- then failwith "I need a cocci file, use -sp_file <file>";
-
- if !dir && !Flag.patch = None
- then
- (match xs with
- | [] -> Flag.patch := Some x
- | _ ->
- pr2
- ("warning: patch output can only be created when only one\n"^
- "directory is specified or when the -patch flag is used")
- );
-
- let infiles =
- Common.profile_code "Main.infiles computation" (fun () ->
- match !dir, !kbuild_info, !Flag.use_glimpse with
- (* glimpse *)
- | false, _, true ->
- failwith "-use_glimpse works only with -dir"
- | true, s, true when s <> "" ->
- failwith "-use_glimpse does not work with -kbuild"
- | true, "", true ->
- if not (null xs)
- then failwith "-use_glimpse can accept only one dir";
-
- let files =
- match glimpse_filter (!cocci_file, !Config.std_iso) x with
- None ->
- Common.cmd_to_list (* same as "true, "", _" case *)
- (if !include_headers
- then ("find "^(join " " (x::xs))^" -name \"*.[ch]\"")
- else ("find "^(join " " (x::xs))^" -name \"*.c\""))
- | Some files -> files in
- files +> List.map (fun x -> [x])
- (* normal *)
- | false, _, _ -> [x::xs]
- | true, "", _ ->
- Common.cmd_to_list
- (if !include_headers
- then ("find "^(join " " (x::xs))^" -name \"*.[ch]\"")
- else ("find "^(join " " (x::xs))^" -name \"*.c\""))
- +> List.map (fun x -> [x])
-
- (* kbuild *)
- | true, kbuild_info_file,_ ->
- let dirs =
- Common.cmd_to_list ("find "^(join " " (x::xs))^" -type d")
- in
- let info = Kbuild.parse_kbuild_info kbuild_info_file in
- let groups = Kbuild.files_in_dirs dirs info in
-
- groups +> List.map (function Kbuild.Group xs -> xs)
- )
- in
-
- let infiles =
- match (!distrib_index,!distrib_max) with
- (None,None) -> infiles
- | (Some index,Some max) ->
- (if index >= max
- then
- failwith "index starts at 0, and so must be less than max");
- if !mod_distrib
- then
- let rec loop ct = function
- [] -> []
- | x::xs ->
- if (ct mod max) = index
- then x::(loop (ct+1) xs)
- else loop (ct+1) xs in
- loop 0 infiles
- else
- begin
- let all_files = List.length infiles in
- let regions = (all_files + (max - 1)) / max in
- let this_min = index * regions in
- let this_max = (index+1) * regions in
- let rec loop ct = function
- [] -> []
- | x::xs ->
- if this_min <= ct && ct < this_max
- then x::(loop (ct+1) xs)
- else loop (ct+1) xs in
- loop 0 infiles
- end
- | _ -> failwith "inconsistent distribution information" in
-
- let outfiles =
- Common.profile_code "Main.outfiles computation" (fun () ->
- infiles +> List.map (fun cfiles ->
- pr2 ("HANDLING: " ^ (join " " cfiles));
- Common.timeout_function_opt !FC.timeout (fun () ->
- Common.report_if_take_time 10 (join " " cfiles) (fun () ->
- (* Unix.sleep 1; *)
- try
- (* this is the main call *)
- Cocci.full_engine (!cocci_file, !Config.std_iso) cfiles
- with
- | Common.UnixExit x -> raise (Common.UnixExit x)
- | e ->
- if !dir
- then begin
- pr2 ("EXN:" ^ Printexc.to_string e);
- [] (* *)
- end
- else raise e)))
- ) +> List.concat
- in
-
- Common.profile_code "Main.result analysis" (fun () ->
-
- Ctlcocci_integration.print_bench();
-
- let outfiles = Cocci.check_duplicate_modif outfiles in
-
- outfiles +> List.iter (fun (infile, outopt) ->
- outopt +> Common.do_option (fun outfile ->
- if !inplace_modif
- then begin
- Common.command2 ("cp "^infile^" "^infile^".cocci_orig");
- Common.command2 ("cp "^outfile^" "^infile);
- end;
-
- if !outplace_modif
- then Common.command2 ("cp "^outfile^" "^infile^".cocci_res");
-
- if !output_file = ""
- then begin
- let tmpfile = "/tmp/"^Common.basename infile in
- pr2 (spf "One file modified. Result is here: %s" tmpfile);
- Common.command2 ("cp "^outfile^" "^tmpfile);
- end
- ));
- if !output_file <> "" then
- (match outfiles with
- | [infile, Some outfile] when infile = x && null xs ->
- Common.command2 ("cp " ^outfile^ " " ^ !output_file);
- | [infile, None] when infile = x && null xs ->
- Common.command2 ("cp " ^infile^ " " ^ !output_file);
- | _ ->
- failwith
- ("-o can not be applied because there is multiple " ^
- "modified files");
- );
-
- if !compare_with_expected
- then Testing.compare_with_expected outfiles))
-
- (* --------------------------------------------------------- *)
- (* empty entry *)
- (* --------------------------------------------------------- *)
- | [] -> short_usage()
-
- ));
- if !Pycocci.initialised && (Pycocci.py_isinitialized ()) != 0 then begin
- ignore(Pycocci.pyrun_simplestring "cocci.finalise()");
- if !Flag.show_misc
- then Common.pr2 "Finalizing python\n";
- Pycocci.py_finalize ();
- end
- end
-
-(*****************************************************************************)
-let _ =
- Common.main_boilerplate (fun () ->
- run_profile quiet_profile;
- main ();
- Ctlcocci_integration.print_bench();
- )
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-module FC = Flag_cocci
-
-(*****************************************************************************)
-(* Flags *)
-(*****************************************************************************)
-
-(* In addition to flags that can be tweaked via -xxx options (cf the
- * full list of options in "the spatch options" section below), the
- * spatch program also depends on external files, described in
- * globals/config.ml, mainly a standard.h and standard.iso file *)
-
-let cocci_file = ref ""
-
-let output_file = ref ""
-let inplace_modif = ref false (* but keeps a .cocci_orig *)
-let outplace_modif = ref false (* generates a .cocci_res *)
-
-(* could be avoided by using Common.files_of_dir_or_files instead *)
-let dir = ref false
-
-let include_headers = ref false
-let kbuild_info = ref ""
-
-(* test mode *)
-let test_mode = ref false
-let test_all = ref false
-let test_okfailed = ref false
-let test_regression_okfailed = ref false
-
-
-(* action mode *)
-let action = ref ""
-
-(* works with -test but also in "normal" spatch mode *)
-let compare_with_expected = ref false
-
-
-let distrib_index = ref (None : int option)
-let distrib_max = ref (None : int option)
-let mod_distrib = ref false
-
-
-(*****************************************************************************)
-(* Profiles *)
-(*****************************************************************************)
-
-(* pair of (list of flags to set true, list of flags to set false *)
-let quiet_profile = (
- [
- ],
- [
- (* FC.show_diff; just leave this as it is *)
-
- Flag.show_misc;
- Flag.show_trying;
- Flag.show_transinfo;
-
- FC.show_c;
- FC.show_cocci;
- FC.show_flow;
- FC.show_before_fixed_flow;
- FC.show_ctl_tex;
- FC.show_ctl_text;
- FC.show_binding_in_out;
-
- Flag_parsing_cocci.show_SP;
- Flag_parsing_cocci.show_iso_failures;
- Flag_ctl.verbose_ctl_engine;
- Flag_ctl.verbose_match;
- Flag_matcher.debug_engine;
- Flag_parsing_c.debug_unparsing;
- Flag_parsing_c.verbose_type;
- Flag_parsing_c.verbose_parsing;
- ])
-
-(* some information that is useful in seeing why a semantic patch doesn't
-work properly *)
-let debug_profile = (
- [
- Flag.show_misc;
- FC.show_diff;
- FC.show_cocci;
- FC.show_binding_in_out;
- FC.show_dependencies;
- Flag.show_transinfo;
- Flag_parsing_cocci.show_iso_failures;
- ],
- [
-
- Flag.show_misc;
-
- FC.show_c;
- FC.show_flow;
- FC.show_before_fixed_flow;
- FC.show_ctl_tex;
- FC.show_ctl_text;
-
- Flag_parsing_cocci.show_SP;
- Flag_ctl.verbose_ctl_engine;
- Flag_ctl.verbose_match;
- Flag_matcher.debug_engine;
- Flag_parsing_c.debug_unparsing;
- Flag_parsing_c.verbose_type;
- Flag_parsing_c.verbose_parsing;
- ])
-
-let pad_profile = (
- [
- FC.show_diff;
- ],
- [
-
- Flag.show_misc;
- Flag.show_transinfo;
-
- FC.show_c;
- FC.show_cocci;
- FC.show_flow;
- FC.show_before_fixed_flow;
- FC.show_ctl_tex;
- FC.show_ctl_text;
- FC.show_binding_in_out;
-
- Flag_parsing_cocci.show_SP;
- Flag_parsing_cocci.show_iso_failures;
- Flag_ctl.verbose_ctl_engine;
- Flag_ctl.verbose_match;
- Flag_matcher.debug_engine;
- Flag_parsing_c.debug_unparsing;
- Flag_parsing_c.verbose_type;
- Flag_parsing_c.verbose_parsing;
- ])
-
-let run_profile p =
- let (set_to_true, set_to_false) = p in
- List.iter (fun x -> x := false) set_to_false;
- List.iter (fun x -> x := true) set_to_true
-
-(*****************************************************************************)
-(* The spatch options *)
-(*****************************************************************************)
-
-let usage_msg =
- "Usage: " ^ basename Sys.argv.(0) ^
- " -sp_file <SP> <infile> [-o <outfile>] [-iso_file <iso>] [options]" ^
- "\n" ^ "Options are:"
-
-(* forward reference trick *)
-let short_usage_func = ref (fun () -> ())
-let long_usage_func = ref (fun () -> ())
-
-
-(* The short_options are user-oriented. The other options are for
- * the developers of coccinelle or advanced-users that know
- * quite well the underlying semantics of coccinelle.
- *)
-
-
-(* will be printed when use only ./spatch. For the rest you have to
- * use -longhelp to see them.
- *)
-let short_options = [
- "-sp_file", Arg.Set_string cocci_file,
- " <file> the semantic patch file";
-
- "-o", Arg.Set_string output_file,
- " <file> the output file";
- "-inplace", Arg.Set inplace_modif,
- " do the modification on the file directly";
- "-outplace", Arg.Set outplace_modif,
- " store modifications in a .cocci_res file";
-
- "-U", Arg.Int (fun n -> Flag_parsing_c.diff_lines := Some (i_to_s n)),
- " set number of diff context lines";
- "-partial_match", Arg.Set Flag_ctl.partial_match,
- " report partial matches of the SP on the C file";
-
- "-iso_file", Arg.Set_string Config.std_iso,
- " <file> (default=" ^ !Config.std_iso ^")";
- "-macro_file", Arg.Set_string Config.std_h,
- " <file> (default=" ^ !Config.std_h ^ ")";
-
- "-all_includes",
- Arg.Unit (function _ -> FC.include_options := FC.I_ALL_INCLUDES),
- " causes all available include files to be used";
- "-no_includes",
- Arg.Unit (function _ -> FC.include_options := FC.I_NO_INCLUDES),
- " causes not even local include files to be used";
- "-local_includes",
- Arg.Unit (function _ -> FC.include_options := FC.I_NORMAL_INCLUDES),
- " causes local include files to be used";
- "-include_headers", Arg.Set include_headers,
- " process header files independently";
- "-I", Arg.Set_string FC.include_path,
- " <dir> containing the Linux headers (optional)";
-
-
- "-dir", Arg.Set dir,
- " <dir> process all files in directory recursively";
-
- "-use_glimpse", Arg.Set Flag.use_glimpse,
- " works with -dir, use info generated by glimpseindex";
- "-patch", Arg.String (function s -> Flag.patch := Some s),
- (" <dir> path name with respect to which a patch should be created\n"^
- " \"\" for a file in the current directory");
- "-kbuild_info", Arg.Set_string kbuild_info,
- " <file> improve -dir by grouping related c files";
- "-pyoutput", Arg.Set_string Flag.pyoutput,
- " Sets output routine: Standard values: <coccilib.output.Gtk|coccilib.output.Console>";
-
-
- "-version", Arg.Unit (fun () ->
- pr2 (spf "spatch version: %s" Config.version);
- exit 0;
- ),
- " guess what";
-
- "-date", Arg.Unit (fun () ->
- pr2 "version: $Date: 2009/02/03 17:17:04 $";
- raise (Common.UnixExit 0)
- ),
- " guess what";
-
- "-shorthelp", Arg.Unit (fun () ->
- !short_usage_func();
- raise (Common.UnixExit 0)
- ),
- " see short list of options";
- "-longhelp", Arg.Unit (fun () ->
- !long_usage_func();
- raise (Common.UnixExit 0)
- ),
- " see all the available options in different categories";
- "-help", Arg.Unit (fun () ->
- !long_usage_func();
- raise (Common.UnixExit 0)
- ),
- " ";
- "--help", Arg.Unit (fun () ->
- !long_usage_func();
- raise (Common.UnixExit 0)
- ),
- " ";
-
-]
-
-(* the format is a list of triples:
- * (title of section * (optional) explanation of sections * option list)
- *)
-let other_options = [
- "aliases and obsolete options",
- "",
- [
- "-cocci_file", Arg.Set_string cocci_file,
- " <file> the semantic patch file";
- "-c", Arg.Set_string cocci_file, " short option of -cocci_file";
- "-iso", Arg.Set_string Config.std_iso, " short option of -iso_file";
- "-D", Arg.Set_string Config.std_h, " short option of -macro_file";
- ];
-
- "most useful show options",
- "",
- [
- "-show_diff" , Arg.Set FC.show_diff, " ";
- "-no_show_diff" , Arg.Clear FC.show_diff, " ";
- "-show_flow" , Arg.Set FC.show_flow, " ";
- (* works in conjunction with -show_ctl_text *)
- "-ctl_inline_let",
- Arg.Unit
- (function _ -> FC.show_ctl_text := true; FC.inline_let_ctl := true), " ";
- "-ctl_show_mcodekind",
- Arg.Unit
- (function _ -> FC.show_ctl_text := true; FC.show_mcodekind_in_ctl := true),
- " ";
- "-show_bindings", Arg.Set FC.show_binding_in_out, " ";
- "-show_transinfo", Arg.Set Flag.show_transinfo, " ";
- "-show_misc", Arg.Set Flag.show_misc, " ";
- "-show_trying", Arg.Set Flag.show_trying,
- " show the name of each function being processed";
- "-show_dependencies",
- Arg.Unit (function _ -> FC.show_dependencies := true;
- FC.show_binding_in_out := true),
- " show the dependencies related to each rule";
- ];
-
- "verbose subsystems options",
- "",
- [
- "-verbose_ctl_engine",
- Arg.Unit (function _ ->
- Flag_ctl.verbose_ctl_engine := true; FC.show_ctl_text := true) , " ";
- "-verbose_match", Arg.Set Flag_ctl.verbose_match, " ";
- "-verbose_engine", Arg.Set Flag_matcher.debug_engine, " ";
- "-graphical_trace", Arg.Set Flag_ctl.graphical_trace, " generate a pdf file representing the matching process";
- "-gt_without_label",
- Arg.Unit (function _ ->
- Flag_ctl.graphical_trace := true; Flag_ctl.gt_without_label := true),
- " remove graph label (requires option -graphical_trace)";
-
- "-parse_error_msg", Arg.Set Flag_parsing_c.verbose_parsing, " ";
- "-type_error_msg", Arg.Set Flag_parsing_c.verbose_type, " ";
- (* could also use Flag_parsing_c.options_verbose *)
- ];
-
- "other show options",
- "",
- [
- "-show_c" , Arg.Set FC.show_c, " ";
- "-show_cocci" , Arg.Set FC.show_cocci, " ";
- "-show_before_fixed_flow" , Arg.Set FC.show_before_fixed_flow, " ";
- "-show_ctl_tex" , Arg.Set FC.show_ctl_tex, " ";
- "-show_ctl_text" , Arg.Set FC.show_ctl_text, " ";
- "-show_SP" , Arg.Set Flag_parsing_cocci.show_SP, " ";
- ];
-
-
- "debug C parsing/unparsing",
- "",
- [
- "-debug_cpp", Arg.Set Flag_parsing_c.debug_cpp, " ";
- "-debug_lexer", Arg.Set Flag_parsing_c.debug_lexer , " ";
- "-debug_etdt", Arg.Set Flag_parsing_c.debug_etdt , " ";
- "-debug_typedef", Arg.Set Flag_parsing_c.debug_typedef, " ";
-
- "-filter_msg", Arg.Set Flag_parsing_c.filter_msg ,
- " filter some cpp message when the macro is a \"known\" cpp construct";
- "-filter_define_error",Arg.Set Flag_parsing_c.filter_define_error," ";
- "-filter_passed_level", Arg.Set_int Flag_parsing_c.filter_passed_level," ";
-(* debug cfg doesn't seem to have any effect, so drop it as an option *)
-(* "-debug_cfg", Arg.Set Flag_parsing_c.debug_cfg , " "; *)
- "-debug_unparsing", Arg.Set Flag_parsing_c.debug_unparsing, " ";
-
- ];
- (* could use Flag_parsing_c.options_debug_with_title instead *)
-
-
- "shortcut for enabling/disabling a set of debugging options at once",
- "",
- [
- (* todo: other profile ? *)
- "-quiet", Arg.Unit (fun () -> run_profile quiet_profile), " ";
- "-debug", Arg.Unit (fun () -> run_profile debug_profile), " ";
- "-pad", Arg.Unit (fun () -> run_profile pad_profile), " ";
-
- ];
-
- "bench options",
- "",
- [
- "-profile", Arg.Unit (function () -> Common.profile := Common.PALL) ,
- " gather timing information about the main coccinelle functions";
- "-bench", Arg.Int (function x -> Flag_ctl.bench := x),
- " <level> for profiling the CTL engine";
- "-timeout", Arg.Int (fun x -> FC.timeout := Some x),
- " <sec> timeout in seconds";
- "-steps", Arg.Int (fun x -> Flag_ctl.steps := Some x),
- " max number of model checking steps per code unit";
- "-track_iso", Arg.Set Flag.track_iso_usage,
- " gather information about isomorphism usage";
- "-profile_iso",
- Arg.Unit
- (function () ->
- Common.profile:=PSOME ["parse cocci";"mysat";"asttoctl2";"full_engine"]),
- " gather information about the cost of isomorphism usage"
- ];
-
-
-
- "change of algorithm options",
- "",
- [
- "-popl", Arg.Set FC.popl,
- " simplified SmPL, for the popl paper";
-
- "-popl_mark_all",
- Arg.Unit
- (function _ -> FC.popl := true; Flag_popl.mark_all := true),
- " simplified SmPL, for the popl paper";
-
- "-popl_keep_all_wits",
- Arg.Unit
- (function _ -> FC.popl := true; Flag_popl.keep_all_wits := true),
- " simplified SmPL, for the popl paper";
-
- "-hrule", Arg.String
- (function s ->
- Flag.make_hrule := Some s; FC.include_options := FC.I_NO_INCLUDES),
- " semantic patch generation";
-
- "-loop", Arg.Set Flag_ctl.loop_in_src_code, " ";
-
- "-l1", Arg.Clear Flag_parsing_c.label_strategy_2, " ";
- "-ifdef_to_if", Arg.Set FC.ifdef_to_if,
- " convert ifdef to if (experimental)";
-
- "-noif0_passing", Arg.Clear Flag_parsing_c.if0_passing,
- " ";
- "-noadd_typedef_root", Arg.Clear Flag_parsing_c.add_typedef_root, " ";
- (* could use Flag_parsing_c.options_algo instead *)
-
-
- "-disallow_nested_exps", Arg.Set Flag_matcher.disallow_nested_exps,
- "disallow an expresion pattern from matching a term and its subterm";
- "-disable_worth_trying_opt", Arg.Clear FC.worth_trying_opt,
- " ";
- "-only_return_is_error_exit",
- Arg.Set Flag_matcher.only_return_is_error_exit,
- "if this flag is not set, then break and continue are also error exits";
- (* the following is a hack to make it easier to add code in sgrep-like
- code, essentially to compensate for the fact that we don't have
- any way of printing things out *)
- "-allow_inconsistent_paths",
- Arg.Set Flag_matcher.allow_inconsistent_paths,
- "if this flag is set don't check for inconsistent paths; dangerous";
- ];
-
- "misc options",
- "",
- [
- "-debugger", Arg.Set Common.debugger ,
- " option to set if launch spatch in ocamldebug";
- "-disable_once", Arg.Set Common.disable_pr2_once,
- " to print more messages";
- "-save_tmp_files", Arg.Set Common.save_tmp_files, " ";
- ];
-
- "concurrency",
- "",
- [
- "-index", Arg.Int (function x -> distrib_index := Some x) ,
- " the processor to use for this run of spatch";
- "-max", Arg.Int (function x -> distrib_max := Some x) ,
- " the number of processors available";
- "-mod_distrib", Arg.Set mod_distrib,
- " use mod to distribute files among the processors";
- ];
-
- "pad options",
- "",
- [
- "-use_cache", Arg.Set Flag_parsing_c.use_cache,
- " use .ast_raw pre-parsed cached C file";
- (* could use Flag_parsing_c.options_pad instead *)
- ];
-
-
-
- "test mode and test options (works with tests/ or .ok files)",
- "The test options don't work with the -sp_file and so on.",
- [
- "-test", Arg.Set test_mode,
- " <file> launch spatch on tests/file.[c,cocci]";
- "-testall", Arg.Set test_all,
- " launch spatch on all files in tests/ having a .res";
- "-test_okfailed", Arg.Set test_okfailed,
- " generates .{ok,failed,spatch_ok} files using .res files";
- "-test_regression_okfailed", Arg.Set test_regression_okfailed,
- " process the .{ok,failed,spatch_ok} files in current dir";
-
- "-compare_with_expected", Arg.Set compare_with_expected,
- " use also file.res";
- "-relax_include_path", Arg.Set FC.relax_include_path,
- " ";
-
- ];
-
- "action mode",
- ("The action options don't work with the -sp_file and so on." ^ "\n" ^
- "It's for the other (internal) uses of the spatch program."
- ),
-
- (* -token_c, -parse_c, etc *)
- ((Common.options_of_actions action (Test_parsing_c.actions())) ++
- [
- (let s = "-parse_cocci" in s, Arg.Unit (fun () -> action := s),
- " <file>");
- (let s = "-compare_c" in s, Arg.Unit (fun () -> action := s),
- " <file1> <file2>");
- ]);
-]
-
-
-let all_options =
- short_options ++ List.concat (List.map Common.thd3 other_options)
-
-
-
-(* I don't want the -help and --help that are appended by Arg.align *)
-let arg_align2 xs =
- Arg.align xs +> List.rev +> Common.drop 2 +> List.rev
-
-(* copy paste of Arg.parse. Don't want the default -help msg *)
-let arg_parse2 l f msg =
- (try
- Arg.parse_argv Sys.argv l f msg;
- with
- | Arg.Bad msg -> (* eprintf "%s" msg; exit 2; *)
- let xs = Common.lines msg in
- (* take only head, it's where the error msg is *)
- pr2 (List.hd xs);
- !short_usage_func();
- raise (Common.UnixExit (2))
- | Arg.Help msg -> (* printf "%s" msg; exit 0; *)
- raise Impossible (* -help is specified in speclist *)
- )
-
-
-let short_usage () =
- begin
- Common.short_usage usage_msg short_options;
- pr2 "";
- pr2 "Example of use:";
- pr2 " ./spatch -sp_file foo.cocci foo.c -o /tmp/newfoo.c";
- pr2 "";
- end
-
-
-let long_usage () =
- Common.long_usage usage_msg short_options other_options
-
-let _ = short_usage_func := short_usage
-let _ = long_usage_func := long_usage
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-let adjust_stdin cfile k =
- if !dir
- then k()
- else
- let newin =
- try
- let (dir, base, ext) = Common.dbe_of_filename cfile in
- let varfile = Common.filename_of_dbe (dir, base, "var") in
- if ext = "c" && Common.lfile_exists varfile
- then Some varfile
- else None
- with Invalid_argument("Filename.chop_extension") -> None
- in
- Common.redirect_stdin_opt newin k
-
-let glimpse_filter (coccifile, isofile) dir =
- let (_metavars,astcocci,_free_var_lists,_negated_positions,
- _used_after_lists,_positions_lists,_,query) =
- Cocci.sp_of_file coccifile (Some isofile) in
- match query with
- None -> pr2 "no glimpse keyword inferred from snippet"; None
- | Some query ->
- let suffixes = if !include_headers then ["c";"h"] else ["c"] in
- pr2 ("glimpse request = " ^ query);
- let command = spf "glimpse -y -H %s -N -W -w '%s'" dir query in
- let (glimpse_res,stat) = Common.cmd_to_list_and_status command in
- match stat with
- Unix.WEXITED(0) | Unix.WEXITED(1) ->
- Some
- (glimpse_res +>
- List.filter
- (fun file -> List.mem (Common.filesuffix file) suffixes))
- | _ -> None (* error, eg due to pattern too big *)
-
-
-
-
-(*****************************************************************************)
-(* The coccinelle main entry point *)
-(*****************************************************************************)
-let main () =
- begin
- let arglist = Array.to_list Sys.argv in
-
- if not (null (Common.inter_set arglist
- ["-cocci_file";"-sp_file";"-test";"-testall";
- "-test_okfailed";"-test_regression_okfailed"]))
- then run_profile quiet_profile;
-
- let args = ref [] in
-
- (* this call can set up many global flag variables via the cmd line *)
- arg_parse2 (Arg.align all_options) (fun x -> args := x::!args) usage_msg;
-
- (if !dir && List.length !args > 1
- then
- begin
- let chosen = List.hd !args in
- pr2 ("ignoring all but the last specified directory: "^chosen);
- args := [chosen]
- end);
- args := List.rev !args;
-
- if !cocci_file <> "" && (not (!cocci_file =~ ".*\\.\\(sgrep\\|spatch\\)$"))
- then cocci_file := Common.adjust_ext_if_needed !cocci_file ".cocci";
-
- if !Config.std_iso <> ""
- then Config.std_iso := Common.adjust_ext_if_needed !Config.std_iso ".iso";
- if !Config.std_h <> ""
- then Config.std_h := Common.adjust_ext_if_needed !Config.std_h ".h";
-
- if !Config.std_h <> ""
- then Parse_c.init_defs !Config.std_h;
-
-
- (* must be done after Arg.parse, because Common.profile is set by it *)
- Common.profile_code "Main total" (fun () ->
-
-
- let all_actions = Test_parsing_c.actions() in
-
- (match (!args) with
-
- (* --------------------------------------------------------- *)
- (* The test framework. Works with tests/ or .ok and .failed *)
- (* --------------------------------------------------------- *)
- | [x] when !test_mode ->
- FC.include_path := "tests/include";
- Testing.testone x !compare_with_expected
-
- | [] when !test_all ->
- FC.include_path := "tests/include";
- Testing.testall ()
-
- | [] when !test_regression_okfailed ->
- Testing.test_regression_okfailed ()
-
- | x::xs when !test_okfailed ->
- (* do its own timeout on FC.timeout internally *)
- FC.relax_include_path := true;
- adjust_stdin x (fun () ->
- Testing.test_okfailed !cocci_file (x::xs)
- )
-
- (* --------------------------------------------------------- *)
- (* Actions, useful to debug subpart of coccinelle *)
- (* --------------------------------------------------------- *)
-
- | xs when List.mem !action (Common.action_list all_actions) ->
- Common.do_action !action xs all_actions
-
- | [file] when !action = "-parse_cocci" ->
- Testing.test_parse_cocci file
-
- (* I think this is used by some scripts in some Makefile for our
- * big-tests. So dont remove.
- *)
- | [file1;file2] when !action = "-compare_c" ->
- Test_parsing_c.test_compare_c file1 file2 (* result = unix code *)
-
- (* could add the Test_parsing_c.test_actions such as -parse_c & co *)
-
-
- (* --------------------------------------------------------- *)
- (* This is the main entry *)
- (* --------------------------------------------------------- *)
- | x::xs ->
-
- adjust_stdin x (fun () ->
- if !cocci_file = ""
- then failwith "I need a cocci file, use -sp_file <file>";
-
- if !dir && !Flag.patch = None
- then
- (match xs with
- | [] -> Flag.patch := Some x
- | _ ->
- pr2
- ("warning: patch output can only be created when only one\n"^
- "directory is specified or when the -patch flag is used")
- );
-
- let infiles =
- Common.profile_code "Main.infiles computation" (fun () ->
- match !dir, !kbuild_info, !Flag.use_glimpse with
- (* glimpse *)
- | false, _, true ->
- failwith "-use_glimpse works only with -dir"
- | true, s, true when s <> "" ->
- failwith "-use_glimpse does not work with -kbuild"
- | true, "", true ->
- if not (null xs)
- then failwith "-use_glimpse can accept only one dir";
-
- let files =
- match glimpse_filter (!cocci_file, !Config.std_iso) x with
- None ->
- Common.cmd_to_list (* same as "true, "", _" case *)
- (if !include_headers
- then ("find "^(join " " (x::xs))^" -name \"*.[ch]\"")
- else ("find "^(join " " (x::xs))^" -name \"*.c\""))
- | Some files -> files in
- files +> List.map (fun x -> [x])
- (* normal *)
- | false, _, _ -> [x::xs]
- | true, "", _ ->
- Common.cmd_to_list
- (if !include_headers
- then ("find "^(join " " (x::xs))^" -name \"*.[ch]\"")
- else ("find "^(join " " (x::xs))^" -name \"*.c\""))
- +> List.map (fun x -> [x])
-
- (* kbuild *)
- | true, kbuild_info_file,_ ->
- let dirs =
- Common.cmd_to_list ("find "^(join " " (x::xs))^" -type d")
- in
- let info = Kbuild.parse_kbuild_info kbuild_info_file in
- let groups = Kbuild.files_in_dirs dirs info in
-
- groups +> List.map (function Kbuild.Group xs -> xs)
- )
- in
-
- let infiles =
- match (!distrib_index,!distrib_max) with
- (None,None) -> infiles
- | (Some index,Some max) ->
- (if index >= max
- then
- failwith "index starts at 0, and so must be less than max");
- if !mod_distrib
- then
- let rec loop ct = function
- [] -> []
- | x::xs ->
- if (ct mod max) = index
- then x::(loop (ct+1) xs)
- else loop (ct+1) xs in
- loop 0 infiles
- else
- begin
- let all_files = List.length infiles in
- let regions = (all_files + (max - 1)) / max in
- let this_min = index * regions in
- let this_max = (index+1) * regions in
- let rec loop ct = function
- [] -> []
- | x::xs ->
- if this_min <= ct && ct < this_max
- then x::(loop (ct+1) xs)
- else loop (ct+1) xs in
- loop 0 infiles
- end
- | _ -> failwith "inconsistent distribution information" in
-
- let outfiles =
- Common.profile_code "Main.outfiles computation" (fun () ->
- infiles +> List.map (fun cfiles ->
- pr2 ("HANDLING: " ^ (join " " cfiles));
- Common.timeout_function_opt !FC.timeout (fun () ->
- Common.report_if_take_time 10 (join " " cfiles) (fun () ->
- (* Unix.sleep 1; *)
- try
- (* this is the main call *)
- Cocci.full_engine (!cocci_file, !Config.std_iso) cfiles
- with
- | Common.UnixExit x -> raise (Common.UnixExit x)
- | e ->
- if !dir
- then begin
- pr2 ("EXN:" ^ Printexc.to_string e);
- [] (* *)
- end
- else raise e)))
- ) +> List.concat
- in
-
- Common.profile_code "Main.result analysis" (fun () ->
-
- Ctlcocci_integration.print_bench();
-
- let outfiles = Cocci.check_duplicate_modif outfiles in
-
- outfiles +> List.iter (fun (infile, outopt) ->
- outopt +> Common.do_option (fun outfile ->
- if !inplace_modif
- then begin
- Common.command2 ("cp "^infile^" "^infile^".cocci_orig");
- Common.command2 ("cp "^outfile^" "^infile);
- end;
-
- if !outplace_modif
- then Common.command2 ("cp "^outfile^" "^infile^".cocci_res");
-
- if !output_file = ""
- then begin
- let tmpfile = "/tmp/"^Common.basename infile in
- pr2 (spf "One file modified. Result is here: %s" tmpfile);
- Common.command2 ("cp "^outfile^" "^tmpfile);
- end
- ));
- if !output_file <> "" then
- (match outfiles with
- | [infile, Some outfile] when infile = x && null xs ->
- Common.command2 ("cp " ^outfile^ " " ^ !output_file);
- | [infile, None] when infile = x && null xs ->
- Common.command2 ("cp " ^infile^ " " ^ !output_file);
- | _ ->
- failwith
- ("-o can not be applied because there is multiple " ^
- "modified files");
- );
-
- if !compare_with_expected
- then Testing.compare_with_expected outfiles))
-
- (* --------------------------------------------------------- *)
- (* empty entry *)
- (* --------------------------------------------------------- *)
- | [] -> short_usage()
-
- ));
- if !Pycocci.initialised && (Pycocci.py_isinitialized ()) != 0 then begin
- ignore(Pycocci.pyrun_simplestring "cocci.finalise()");
- if !Flag.show_misc
- then Common.pr2 "Finalizing python\n";
- Pycocci.py_finalize ();
- end
- end
-
-(*****************************************************************************)
-let _ =
- Common.main_boilerplate (fun () ->
- main ();
- Ctlcocci_integration.print_bench();
- )
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-(*****************************************************************************)
-(* Test framework *)
-(*****************************************************************************)
-
-(* There can be multiple .c for the same cocci file. The convention
- * is to have one base.cocci and a base.c and some optional
- * base_vernn.[c,res].
- *
- * If want to test without iso, use -iso_file empty.iso option.
- *)
-let testone x compare_with_expected_flag =
- let x = if x =~ "\\(.*\\)_ver0$" then matched1 x else x in
- let base = if x =~ "\\(.*\\)_ver[0-9]+$" then matched1 x else x in
-
- let cfile = "tests/" ^ x ^ ".c" in
- let cocci_file = "tests/" ^ base ^ ".cocci" in
-
- let expected_res = "tests/" ^ x ^ ".res" in
- begin
- let res = Cocci.full_engine (cocci_file, !Config.std_iso) [cfile] in
- let generated =
- match Common.optionise (fun () -> List.assoc cfile res) with
- | Some (Some outfile) ->
- if List.length res > 1
- then pr2 ("note that not just " ^ cfile ^ " was involved");
-
- let tmpfile = "/tmp/"^Common.basename cfile in
- pr2 (sprintf "One file modified. Result is here: %s" tmpfile);
- Common.command2 ("mv "^outfile^" "^tmpfile);
- tmpfile
- | Some None ->
- pr2 "no modification on the input file";
- cfile
- | None -> raise Impossible
- in
- if compare_with_expected_flag
- then
- Compare_c.compare_default generated expected_res
- +> Compare_c.compare_result_to_string
- +> pr2;
- end
-
-
-(* ------------------------------------------------------------------------ *)
-let testall () =
-
- let newscore = empty_score () in
-
- let expected_result_files =
- Common.glob "tests/*.res"
- +> List.filter (fun f -> Common.filesize f > 0)
- +> List.map Filename.basename
- +> List.sort compare
- in
-
- begin
- expected_result_files +> List.iter (fun res ->
- let x = if res =~ "\\(.*\\).res" then matched1 res else raise Impossible
- in
- let base = if x =~ "\\(.*\\)_ver[0-9]+" then matched1 x else x in
- let cfile = "tests/" ^ x ^ ".c" in
- let cocci_file = "tests/" ^ base ^ ".cocci" in
- let expected = "tests/" ^ res in
-
- let timeout_testall = 30 in
-
- try (
- Common.timeout_function timeout_testall (fun () ->
-
- let xs = Cocci.full_engine (cocci_file, !Config.std_iso) [cfile] in
- let generated =
- match List.assoc cfile xs with
- | Some generated -> generated
- | None -> cfile
- in
-
- let (correct, diffxs) = Compare_c.compare_default generated expected
- in
-
- pr2 res;
- (* I don't use Compare_c.compare_result_to_string because
- * I want to indent a little more the messages.
- *)
- (match correct with
- | Compare_c.Correct -> Hashtbl.add newscore res Common.Ok;
- | Compare_c.Pb s ->
- let s = Str.global_replace
- (Str.regexp "\"/tmp/cocci-output.*\"") "<COCCIOUTPUTFILE>" s
- in
- let s =
- "INCORRECT:" ^ s ^ "\n" ^
- " diff (result(<) vs expected_result(>)) = \n" ^
- (diffxs +> List.map(fun s -> " "^s^"\n") +> Common.join "")
- in
- Hashtbl.add newscore res (Common.Pb s)
- | Compare_c.PbOnlyInNotParsedCorrectly s ->
- let s =
- "seems incorrect, but only because of code that " ^
- "was not parsable" ^ s
- in
- Hashtbl.add newscore res (Common.Pb s)
- )
- )
- )
- with exn ->
- Common.reset_pr_indent();
- let s = "PROBLEM\n" ^ (" exn = " ^ Printexc.to_string exn ^ "\n") in
- Hashtbl.add newscore res (Common.Pb s)
- );
-
-
- pr2 "--------------------------------";
- pr2 "statistics";
- pr2 "--------------------------------";
-
- Common.hash_to_list newscore +> List.iter (fun (s, v) ->
- pr_no_nl (Printf.sprintf "%-30s: " s);
- pr_no_nl (
- match v with
- | Common.Ok -> "CORRECT\n"
- | Common.Pb s -> s
- )
- );
- flush stdout; flush stderr;
-
- pr2 "--------------------------------";
- pr2 "regression testing information";
- pr2 "--------------------------------";
- Common.regression_testing newscore
- (Filename.concat Config.path "tests/score_cocci_best.marshalled");
-
-
- pr2 "--------------------------------";
- pr2 "total score";
- pr2 "--------------------------------";
- let total = Common.hash_to_list newscore +> List.length in
- let good = Common.hash_to_list newscore +> List.filter
- (fun (s, v) -> v = Ok) +> List.length
- in
-
- pr2 (sprintf "good = %d/%d" good total);
-
- end
-
-(* ------------------------------------------------------------------------ *)
-
-type okfailed = Ok | SpatchOK | Failed
-
-(* test_to_string *)
-let t_to_s = function
- | Ok -> ".ok"
- | SpatchOK -> ".spatch_ok"
- | Failed -> ".failed"
-
-let delete_previous_result_files infile =
- [Ok;SpatchOK;Failed] +> List.iter (fun kind ->
- Common.command2 ("rm -f " ^ infile ^ t_to_s kind)
- )
-
-(* quite similar to compare_with_expected below *)
-let test_okfailed cocci_file cfiles =
- cfiles +> List.iter delete_previous_result_files;
-
- (* final_files contain the name of an output file (a .ok or .failed
- * or .spatch_ok), and also some additionnal strings to be printed in
- * this output file in addition to the general error message of
- * full_engine. *)
- let final_files = ref [] in
-
-
- let newout =
- Common.new_temp_file "cocci" ".stdout"
- in
-
- let t = Unix.gettimeofday () in
- let time_per_file_str () =
- let t' = Unix.gettimeofday () in
- let tdiff = t' -. t in
- let tperfile = tdiff /. (float_of_int (List.length cfiles)) in
- spf "time: %f" tperfile
- in
-
- Common.redirect_stdout_stderr newout (fun () ->
- try (
- Common.timeout_function_opt !Flag_cocci.timeout (fun () ->
-
-
- let outfiles = Cocci.full_engine (cocci_file, !Config.std_iso) cfiles
- in
-
- let time_str = time_per_file_str () in
-
- outfiles +> List.iter (fun (infile, outopt) ->
- let (dir, base, ext) = Common.dbe_of_filename infile in
- let expected_suffix =
- match ext with
- | "c" -> "res"
- | "h" -> "h.res"
- | s -> pr2 ("WIERD: not a .c or .h :" ^ base ^ "." ^ s);
- "" (* no extension, will compare to same file *)
- in
- let expected_res =
- Common.filename_of_dbe (dir, base, expected_suffix) in
- let expected_res2 =
- Common.filename_of_dbe (dir,"corrected_"^ base,expected_suffix)
- in
-
- (* can delete more than the first delete_previous_result_files
- * because here we can have more files than in cfiles, for instance
- * the header files
- *)
- delete_previous_result_files infile;
-
- match outopt, Common.lfile_exists expected_res with
- | None, false ->
- ()
- | Some outfile, false ->
- let s =("PB: input file " ^ infile ^ " modified but no .res") in
- push2 (infile^t_to_s Failed, [s;time_str]) final_files
-
- | x, true ->
- let outfile =
- match x with
- | Some outfile -> outfile
- | None -> infile
- in
-
- let diff = Compare_c.compare_default outfile expected_res in
- let s1 = (Compare_c.compare_result_to_string diff) in
- if fst diff = Compare_c.Correct
- then push2 (infile ^ (t_to_s Ok), [s1;time_str]) final_files
- else
- if Common.lfile_exists expected_res2
- then begin
- let diff = Compare_c.compare_default outfile expected_res2 in
- let s2 = Compare_c.compare_result_to_string diff in
- if fst diff = Compare_c.Correct
- then push2 (infile ^ (t_to_s SpatchOK),[s2;s1;time_str])
- final_files
- else push2 (infile ^ (t_to_s Failed), [s2;s1;time_str])
- final_files
- end
- else push2 (infile ^ (t_to_s Failed), [s1;time_str]) final_files
- )
- );
- )
- with exn ->
- let clean s =
- Str.global_replace (Str.regexp "\\\\n") "\n"
- (Str.global_replace (Str.regexp ("\\\\\"")) "\""
- (Str.global_replace (Str.regexp "\\\\t") "\t" s)) in
- let s = "PROBLEM\n"^(" exn = " ^ clean(Printexc.to_string exn) ^ "\n")
- in
- let time_str = time_per_file_str ()
- in
- (* we may miss some file because cfiles is shorter than outfiles.
- * For instance the detected local headers are not in cfiles, so
- * may have less failed. But at least have some failed.
- *)
- cfiles +> List.iter (fun infile ->
- push2 (infile ^ (t_to_s Failed), [s;time_str]) final_files;
- );
- );
- !final_files +> List.iter (fun (file, additional_strs) ->
- Common.command2 ("cp " ^ newout ^ " " ^ file);
- with_open_outfile file (fun (pr, chan) ->
- additional_strs +> List.iter (fun s -> pr (s ^ "\n"))
- );
-
- )
-
-
-let test_regression_okfailed () =
-
- (* it's xxx.c.ok *)
- let chop_ext f = f +> Filename.chop_extension in
-
- let newscore = Common.empty_score () in
- let oks =
- Common.cmd_to_list ("find -name \"*.ok\"")
- ++
- Common.cmd_to_list ("find -name \"*.spatch_ok\"")
- in
- let failed = Common.cmd_to_list ("find -name \"*.failed\"") in
-
- if null (oks ++ failed)
- then failwith "no ok/failed file, you certainly did a make clean"
- else begin
- oks +> List.iter (fun s ->
- Hashtbl.add newscore (chop_ext s) Common.Ok
- );
- failed +> List.iter (fun s ->
- Hashtbl.add newscore (chop_ext s) (Common.Pb "fail")
- );
- pr2 "--------------------------------";
- pr2 "regression testing information";
- pr2 "--------------------------------";
- Common.regression_testing newscore ("score_failed.marshalled")
- end
-
-
-(* ------------------------------------------------------------------------ *)
-(* quite similar to test_ok_failed. Maybe could factorize code *)
-let compare_with_expected outfiles =
- pr2 "";
- outfiles +> List.iter (fun (infile, outopt) ->
- let (dir, base, ext) = Common.dbe_of_filename infile in
- let expected_suffix =
- match ext with
- | "c" -> "res"
- | "h" -> "h.res"
- | s -> failwith ("wierd C file, not a .c or .h :" ^ s)
- in
- let expected_res =
- Common.filename_of_dbe (dir, base, expected_suffix) in
- let expected_res2 =
- Common.filename_of_dbe (dir,"corrected_"^ base,expected_suffix)
- in
-
- match outopt, Common.lfile_exists expected_res with
- | None, false -> ()
- | Some outfile, false ->
- let s =("PB: input file " ^ infile ^ " modified but no .res") in
- pr2 s
- | x, true ->
- let outfile =
- match x with
- | Some outfile -> outfile
- | None -> infile
- in
- let diff = Compare_c.compare_default outfile expected_res in
- let s1 = (Compare_c.compare_result_to_string diff) in
- if fst diff = Compare_c.Correct
- then pr2_no_nl (infile ^ " " ^ s1)
- else
- if Common.lfile_exists expected_res2
- then begin
- let diff = Compare_c.compare_default outfile expected_res2 in
- let s2 = Compare_c.compare_result_to_string diff in
- if fst diff = Compare_c.Correct
- then pr2 (infile ^ " is spatchOK " ^ s2)
- else pr2 (infile ^ " is failed " ^ s2)
- end
- else pr2 (infile ^ " is failed " ^ s1)
- )
-
-(*****************************************************************************)
-(* Subsystem testing *)
-(*****************************************************************************)
-
-let test_parse_cocci file =
- if not (file =~ ".*\\.cocci")
- then pr2 "warning: seems not a .cocci file";
-
- let (_,xs,_,_,_,_,grep_tokens,query) =
- Parse_cocci.process file (Some !Config.std_iso) false in
- xs +> List.iter Pretty_print_cocci.unparse;
- Printf.printf "grep tokens\n";
- List.iter (function x -> Printf.printf "%s\n" (String.concat " " x))
- grep_tokens;
- if !Flag.use_glimpse
- then match query with None -> pr "No query" | Some x -> pr x
-
-
-
-
-
-
-
-
-(*****************************************************************************)
-(* to be called by ocaml toplevel, to test. *)
-(*****************************************************************************)
-
-(* no point to memoize this one *)
-let sp_of_file file iso = Parse_cocci.process file iso false
-
-(* TODO: Remove
-*)
-
-(*
-let flows_of_ast astc =
- astc +> Common.map_filter (fun e -> ast_to_flow_with_error_messages e)
-
-let one_flow flows =
- List.hd flows
-
-let one_ctl ctls = List.hd (List.hd ctls)
-*)
-
##############################################################################
# don't remove DESTDIR, it can be set by package build system like ebuild
+# for staged installation.
install-common:
mkdir -p $(DESTDIR)$(BINDIR)
mkdir -p $(DESTDIR)$(LIBDIR)
mkdir -p $(DESTDIR)$(SHAREDIR)
mkdir -p $(DESTDIR)$(MANDIR)/man1
- cp standard.h $(DESTDIR)$(SHAREDIR)
- cp standard.iso $(DESTDIR)$(SHAREDIR)
- cp docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
- mkdir -p $(DESTDIR)$(SHAREDIR)/python
- cp -a python/coccilib $(DESTDIR)$(SHAREDIR)/python
- cp -f dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
+ $(INSTALL_DATA) standard.h $(DESTDIR)$(SHAREDIR)
+ $(INSTALL_DATA) standard.iso $(DESTDIR)$(SHAREDIR)
+ $(INSTALL_DATA) docs/spatch.1 $(DESTDIR)$(MANDIR)/man1/
+ @if [ $(FEATURE_PYTHON) -eq 1 ]; then $(MAKE) install-python; fi
@echo ""
@echo "You can also install spatch by copying the program spatch"
@echo "(available in this directory) anywhere you want and"
@echo "give it the right options to find its configuration files."
@echo ""
+install-python:
+ mkdir -p $(DESTDIR)$(SHAREDIR)/python/coccilib/coccigui
+ $(INSTALL_DATA) python/coccilib/*.py \
+ $(DESTDIR)$(SHAREDIR)/python/coccilib
+ $(INSTALL_DATA) python/coccilib/coccigui/*.py \
+ $(DESTDIR)$(SHAREDIR)/python/coccilib/coccigui
+ $(INSTALL_LIB) dllpycaml_stubs.so $(DESTDIR)$(LIBDIR)
+
# user will use spatch to run spatch.opt (native)
install: all.opt install-common
- cp spatch.opt $(DESTDIR)$(SHAREDIR)
- cat scripts/spatch.sh | sed "s|SHAREDIR|$(DESTDIR)$(SHAREDIR)|g" > $(DESTDIR)$(BINDIR)/spatch
+ $(INSTALL_PROGRAM) spatch.opt $(DESTDIR)$(SHAREDIR)
+ cat scripts/spatch.sh | sed "s|SHAREDIR|$(SHAREDIR)|g" > $(DESTDIR)$(BINDIR)/spatch
+ chmod 755 $(DESTDIR)$(BINDIR)/spatch
# user will use spatch to run spatch (bytecode)
install-byte: all install-common
- cp spatch $(DESTDIR)$(SHAREDIR)
- cat scripts/spatch.sh | sed "s|\.opt||" | sed "s|SHAREDIR|$(DESTDIR)$(SHAREDIR)|g" > $(DESTDIR)$(BINDIR)/spatch
+ $(INSTALL_PROGRAM) spatch $(DESTDIR)$(SHAREDIR)
+ cat scripts/spatch.sh | sed "s|\.opt||" | sed "s|SHAREDIR|$(SHAREDIR)|g" > $(DESTDIR)$(BINDIR)/spatch
+ chmod 755 $(DESTDIR)$(BINDIR)/spatch
# user will use spatch.opt to run spatch.opt (native)
install-opt: all.opt install-common
- cp spatch.opt $(DESTDIR)$(SHAREDIR)
- cat scripts/spatch.sh | sed "s|SHAREDIR|$(DESTDIR)$(SHAREDIR)|g" > $(DESTDIR)$(BINDIR)/spatch.opt
+ $(INSTALL_PROGRAM) spatch.opt $(DESTDIR)$(SHAREDIR)
+ cat scripts/spatch.sh | sed "s|SHAREDIR|$(SHAREDIR)|g" > $(DESTDIR)$(BINDIR)/spatch.opt
+ chmod 755 $(DESTDIR)$(BINDIR)/spatch.opt
uninstall:
rm -f $(DESTDIR)$(BINDIR)/spatch
+ rm -f $(DESTDIR)$(BINDIR)/spatch.opt
rm -f $(DESTDIR)$(LIBDIR)/dllpycaml_stubs.so
rm -f $(DESTDIR)$(SHAREDIR)/standard.h
rm -f $(DESTDIR)$(SHAREDIR)/standard.iso
make clean
cp -a . $(TMP)/$(PACKAGE)
cd $(TMP)/$(PACKAGE); cd parsing_cocci/; make parser_cocci_menhir.ml
- cd $(TMP)/$(PACKAGE); rm todo_pos
+ cd $(TMP)/$(PACKAGE); rm -f todo_pos
cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE)
rm -rf $(TMP)/$(PACKAGE)
+++ /dev/null
-# autogenerated by configure
-
-# Where to install the binary
-BINDIR=/usr/local/bin
-
-# Where to install the man pages
-MANDIR=/usr/local/man
-
-# Where to install the lib
-LIBDIR=/usr/local/lib
-
-# Where to install the configuration files
-SHAREDIR=/usr/local/share/coccinelle
-
-# Features
-FEATURE_PYTHON=0
-
-# The OPTBIN variable is here to allow to use ocamlc.opt instead of
-# ocaml, when it is available, which speeds up compilation. So
-# if you want the fast version of the ocaml chain tools, set this var
-# or setenv it to ".opt" in your startup script.
-OPTBIN=.opt
-Release coccinelle-0.1.6
-
-** Language:
- - the ability to add comments
-
-** Features:
- - grouping of generated rules with -hrule option
- - handling of special coccinelle comments
- /* {{coccinelle:skip_start}} */ and
- /* {{coccinelle:skip_end}} */
- allowing to give more hints to the C parser.
- Thanks to Flavien@lebarbe.net for the idea.
- - the ability to print the values of more (but not all) kinds of
- metavariables from python
- - new vim SmPL mode.
- Thanks to Alexander Faroy.
-
-** Bugfix:
- - consider the ident tokens also in the 2 lines before the error line for the
- 10-most-problematic-parsing-errors diagnostic.
- - SmPL parser allows cast as the argument of a pointer
- - SmPL type checker allows enum as an array index
- - Better generation of fresh metavariables names in hrule
- - no more warnings about things that should be metavariables when there is
- a disjunction in a function position
- - bugfix in parser, better error message.
- Thanks to Ali-Erdem OZCAN <ali-erdem.ozcan@st.com> for the bug report.
+Release coccinelle-0.1.6a
+
+Bugfix.
local $_ = join ' ', @ARGV;
# Parse options
-/-h/ || /--help/ and die "usage: $0 [--prefix=path] [--without-python] [--with-trac] [--no-opt]\n\n\t--no-opt\tDo not use the optimimized version of OCaml\n\n";
+/-h/ || /--help/ and die "usage: $0 [--prefix=path] [--without-python] [--with-trac] [--no-opt]\n\n\t--no-opt\tDo not use the optimimized version of OCaml\n\t--opt\tUse the optimimized version of OCaml\n\n";
/--prefix=([^ ]*)/ and $prefix = $1;
/--without-python/ and $python = 0;
/--without-trac/ and $trac = 0;
/--with-trac/ and $trac = 1;
/--no-opt/ and $opt = "";
+/--opt/ and $opt = ".opt";
#if($ARGV[0] =~ "--prefix=(.*)") {
# $prefix = $1;
);
if ($opt eq ".opt") {
- my $opt_check = `which ocamlc.opt 2>&1 | cut -d' ' -f2`;
- if($opt_check =~ "no") {
+ my $opt_check = `which ocamlc.opt 2> /dev/null`;
+ if($opt_check =~ "/ocamlc.opt\$") {
+ pr2 "ocamlc.opt is present.";
+ }
+ else {
+ $opt="";
+ pr2 "ocamlc.opt not found";
+ }
+
+ my $opt_check = `which ocamlopt.opt 2> /dev/null`;
+ if($opt_check =~ "/ocamlopt.opt\$") {
+ pr2 "ocamlopt.opt is present.";
+ }
+ else {
$opt="";
- pr2 "Native version of OCaml not found";
+ pr2 "ocamlopt.opt not found";
+ }
+
+ my $opt_check = `which ocamldep.opt 2> /dev/null`;
+ if($opt_check =~ "/ocamldep.opt\$") {
+ pr2 "ocamldep.opt is present.";
}
else {
- pr2 "Native version of OCaml is present.";
+ $opt="";
+ pr2 "ocamldep.opt not found";
+ }
+
+ my $opt_check = `which ocamllex.opt 2> /dev/null`;
+ if($opt_check =~ "/ocamllex.opt\$") {
+ pr2 "ocamllex.opt is present.";
+ }
+ else {
+ $opt="";
+ pr2 "ocamllex.opt not found";
+ }
+
+ if($opt eq "") {
+ pr2 "At least one native OCaml tool have not been found.";
+ pr2 "Desactivation of all native OCaml tools for compilation.";
}
}
open(CONFIG, ">Makefile.config");
print CONFIG "# autogenerated by configure
+#
+INSTALL_PROGRAM?=install -c -m 755
+INSTALL_LIB?= install -c -m 755
+INSTALL_DATA?= install -c -m 644
+
# Where to install the binary
BINDIR=$prefix/bin
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#note: if you add a file (a .mli or .ml), dont forget to do a make depend
-
-TARGET=ctl
-
-SRC=flag_ctl.ml ast_ctl.ml pretty_print_ctl.ml ctl_engine.ml wrapper_ctl.ml
-
-SYSLIBS=str.cma unix.cma
-LIBS=../commons/commons.cma ../globals/globals.cma
-
-INCLUDES=-I ../commons -I ../commons/ocamlextra -I ../globals
-
-
-#The Caml compilers.
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLDEP = ocamldep$(OPTBIN) #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-
-
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-all: $(LIB)
-all.opt: $(OPTLIB)
-
-$(TARGET).top: $(LIB) test_ctl.cmo
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) test_ctl.cmo
-
-$(LIB): $(OBJS)
- $(OCAMLC) -a -o $(LIB) $(OBJS)
-
-$(OPTLIB): $(OPTOBJS)
- $(OCAMLOPT) -a -o $(OPTLIB) $(OPTOBJS)
-
-clean::
- rm -f $(LIB) $(OPTLIB) $(LIB:.cma=.a) $(TARGET).top
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-
-
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
-distclean::
- rm -f .depend
-
-.depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#note: if you add a file (a .mli or .ml), dont forget to do a make depend
-
-TARGET=ctl
-
-SRC=flag_ctl.ml ast_ctl.ml pretty_print_ctl.ml ctl_engine.ml wrapper_ctl.ml
-
-SYSLIBS=str.cma unix.cma
-LIBS=../commons/commons.cma ../globals/globals.cma
-
-INCLUDES=-I ../commons -I ../commons/ocamlextra -I ../globals
-
-
-#The Caml compilers.
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLDEP = ocamldep$(OPTBIN) $(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-
-
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-all: $(LIB)
-all.opt: $(OPTLIB)
-
-$(TARGET).top: $(LIB) test_ctl.cmo
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) test_ctl.cmo
-
-$(LIB): $(OBJS)
- $(OCAMLC) -a -o $(LIB) $(OBJS)
-
-$(OPTLIB): $(OPTOBJS)
- $(OCAMLOPT) -a -o $(OPTLIB) $(OPTOBJS)
-
-clean::
- rm -f $(LIB) $(OPTLIB) $(LIB:.cma=.a) $(TARGET).top
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-
-
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
-distclean::
- rm -f .depend
-
-.depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-##############################################################################
-# Variables
-##############################################################################
-#TARGET=matcher
-TARGET=cocciengine
-CTLTARGET=engine
-
-SRC= flag_matcher.ml lib_engine.ml pretty_print_engine.ml \
- check_exhaustive_pattern.ml \
- check_reachability.ml \
- c_vs_c.ml isomorphisms_c_c.ml \
- cocci_vs_c.ml pattern_c.ml sgrep.ml transformation_c.ml \
- asttomember.ml asttoctl2.ml ctltotex.ml \
- postprocess_transinfo.ml ctlcocci_integration.ml lib_matcher_c.ml
-
-#c_vs_c.ml
-#SRC= flag_matcher.ml \
-# c_vs_c.ml cocci_vs_c.ml \
-# lib_engine.ml \
-# pattern_c.ml transformation_c.ml
-
-#LIBS=../commons/commons.cma ../parsing_c/parsing_c.cma
-#INCLUDES= -I ../commons -I ../parsing_c
-INCLUDES = -I ../commons -I ../commons/ocamlextra -I ../globals \
- -I ../ctl -I ../parsing_cocci -I ../parsing_c
-LIBS=../commons/commons.cma ../globals/globals.cma \
- ../ctl/ctl.cma ../parsing_c/parsing_c.cma ../parsing_cocci/cocci_parser.cma
-
-SYSLIBS= str.cma unix.cma
-
-
-# just to test asttoctl
-# CTLSOURCES = lib_engine.ml pretty_print_engine.ml asttoctl.ml ctltotex.ml \
-# main.ml
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex$(OPTBIN) #-ml
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep$(OPTBIN) #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-
-##############################################################################
-# Top rules
-##############################################################################
-all: $(TARGET).cma
-all.opt: $(TARGET).cmxa
-
-$(TARGET).cma: $(OBJS)
- $(OCAMLC) -a -o $(TARGET).cma $(OBJS)
-
-$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
- $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
-
-$(TARGET).top: $(OBJS) $(LIBS)
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
-
-clean::
- rm -f $(TARGET).top
-
-
-
-##############################################################################
-# Pad's rules
-##############################################################################
-
-##############################################################################
-# Generic rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[ioxa] *.o *.a *.cmxa *.annot
-clean::
- rm -f *~ .*~ gmon.out #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-##############################################################################
-# Variables
-##############################################################################
-#TARGET=matcher
-TARGET=cocciengine
-CTLTARGET=engine
-
-SRC= flag_matcher.ml lib_engine.ml pretty_print_engine.ml \
- check_exhaustive_pattern.ml \
- check_reachability.ml \
- c_vs_c.ml isomorphisms_c_c.ml \
- cocci_vs_c.ml pattern_c.ml sgrep.ml transformation_c.ml \
- asttomember.ml asttoctl2.ml ctltotex.ml \
- postprocess_transinfo.ml ctlcocci_integration.ml lib_matcher_c.ml
-
-#c_vs_c.ml
-#SRC= flag_matcher.ml \
-# c_vs_c.ml cocci_vs_c.ml \
-# lib_engine.ml \
-# pattern_c.ml transformation_c.ml
-
-#LIBS=../commons/commons.cma ../parsing_c/parsing_c.cma
-#INCLUDES= -I ../commons -I ../parsing_c
-INCLUDES = -I ../commons -I ../commons/ocamlextra -I ../globals \
- -I ../ctl -I ../parsing_cocci -I ../parsing_c
-LIBS=../commons/commons.cma ../globals/globals.cma \
- ../ctl/ctl.cma ../parsing_c/parsing_c.cma ../parsing_cocci/cocci_parser.cma
-
-SYSLIBS= str.cma unix.cma
-
-
-# just to test asttoctl
-# CTLSOURCES = lib_engine.ml pretty_print_engine.ml asttoctl.ml ctltotex.ml \
-# main.ml
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex$(OPTBIN) #-ml
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep$(OPTBIN) $(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-
-##############################################################################
-# Top rules
-##############################################################################
-all: $(TARGET).cma
-all.opt: $(TARGET).cmxa
-
-$(TARGET).cma: $(OBJS)
- $(OCAMLC) -a -o $(TARGET).cma $(OBJS)
-
-$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
- $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
-
-$(TARGET).top: $(OBJS) $(LIBS)
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
-
-clean::
- rm -f $(TARGET).top
-
-
-
-##############################################################################
-# Pad's rules
-##############################################################################
-
-##############################################################################
-# Generic rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[ioxa] *.o *.a *.cmxa *.annot
-clean::
- rm -f *~ .*~ gmon.out #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-##############################################################################
-# Variables
-##############################################################################
-#TARGET=matcher
-TARGET=cocciengine
-CTLTARGET=engine
-
-SRC= flag_matcher.ml lib_engine.ml pretty_print_engine.ml \
- check_exhaustive_pattern.ml \
- check_reachability.ml \
- c_vs_c.ml isomorphisms_c_c.ml \
- cocci_vs_c.ml pattern_c.ml sgrep.ml transformation_c.ml \
- asttomember.ml asttoctl2.ml ctltotex.ml \
- postprocess_transinfo.ml ctlcocci_integration.ml
-
-#c_vs_c.ml
-#SRC= flag_matcher.ml \
-# c_vs_c.ml cocci_vs_c.ml \
-# lib_engine.ml \
-# pattern_c.ml transformation_c.ml
-
-#LIBS=../commons/commons.cma ../parsing_c/parsing_c.cma
-#INCLUDES= -I ../commons -I ../parsing_c
-INCLUDES = -I ../commons -I ../commons/ocamlextra -I ../globals \
- -I ../ctl -I ../parsing_cocci -I ../parsing_c
-LIBS=../commons/commons.cma ../globals/globals.cma \
- ../ctl/ctl.cma ../parsing_c/parsing_c.cma ../parsing_cocci/cocci_parser.cma
-
-SYSLIBS= str.cma unix.cma
-
-
-# just to test asttoctl
-# CTLSOURCES = lib_engine.ml pretty_print_engine.ml asttoctl.ml ctltotex.ml \
-# main.ml
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-
-OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX=ocamllex$(OPTBIN) #-ml
-OCAMLYACC=ocamlyacc -v
-OCAMLDEP=ocamldep$(OPTBIN) $(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
-
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-
-##############################################################################
-# Top rules
-##############################################################################
-all: $(TARGET).cma
-all.opt: $(TARGET).cmxa
-
-$(TARGET).cma: $(OBJS)
- $(OCAMLC) -a -o $(TARGET).cma $(OBJS)
-
-$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
- $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
-
-$(TARGET).top: $(OBJS) $(LIBS)
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
-
-clean::
- rm -f $(TARGET).top
-
-
-
-##############################################################################
-# Pad's rules
-##############################################################################
-
-##############################################################################
-# Generic rules
-##############################################################################
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-.mli.cmi:
- $(OCAMLC) -c $<
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-.ml.mldepend:
- $(OCAMLC) -i $<
-
-clean::
- rm -f *.cm[ioxa] *.o *.a *.cmxa *.annot
-clean::
- rm -f *~ .*~ gmon.out #*#
-
-beforedepend::
-
-depend:: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* true = don't see all matched nodes, only modified ones *)
-let onlyModif = ref true(*false*)
-(* set to true for line numbers in the output of ctl_engine *)
-let line_numbers = ref false
-(* if true, only eg if header is included in not for ...s *)
-let simple_get_end = ref false(*true*)
-
-(* Question: where do we put the existential quantifier for or. At the
-moment, let it float inwards. *)
-
-(* nest shouldn't overlap with what comes after. not checked for. *)
-
-module Ast = Ast_cocci
-module V = Visitor_ast
-module CTL = Ast_ctl
-module FV = Free_vars
-
-let warning s = Printf.fprintf stderr "warning: %s\n" s
-
-type cocci_predicate = Lib_engine.predicate * string Ast_ctl.modif
-type formula =
- (cocci_predicate,string, Wrapper_ctl.info) Ast_ctl.generic_ctl
-
-
-let aftpred = (Lib_engine.After,CTL.Control)
-let retpred = (Lib_engine.Return,CTL.Control)
-let exitpred = (Lib_engine.ErrorExit,CTL.Control)
-
-let intersect l1 l2 = List.filter (function x -> List.mem x l2) l1
-let subset l1 l2 = List.for_all (function x -> List.mem x l2) l1
-
-(* --------------------------------------------------------------------- *)
-
-let rec drop_vs f =
- CTL.rewrap f
- (match CTL.unwrap f with
- CTL.False as x -> x
- | CTL.True as x -> x
- | CTL.Pred(p) as x -> x
- | CTL.Not(phi) -> CTL.Not(drop_vs phi)
- | CTL.Exists(v,phi) ->
- (match CTL.unwrap phi with
- CTL.Pred((x,CTL.Modif v1)) when v = v1 -> CTL.Pred((x,CTL.Control))
- | _ -> CTL.Exists(v,drop_vs phi))
- | CTL.And(phi1,phi2) -> CTL.And(drop_vs phi1,drop_vs phi2)
- | CTL.Or(phi1,phi2) -> CTL.Or(drop_vs phi1,drop_vs phi2)
- | CTL.SeqOr(phi1,phi2) -> CTL.SeqOr(drop_vs phi1,drop_vs phi2)
- | CTL.Implies(phi1,phi2) -> CTL.Implies(drop_vs phi1,drop_vs phi2)
- | CTL.AF(dir,phi1,phi2) -> CTL.AF(dir,drop_vs phi1,drop_vs phi2)
- | CTL.AX(dir,phi) -> CTL.AX(dir,drop_vs phi)
- | CTL.AG(dir,phi) -> CTL.AG(dir,drop_vs phi)
- | CTL.AU(dir,phi1,phi2,phi3,phi4) ->
- CTL.AU(dir,drop_vs phi1,drop_vs phi2,drop_vs phi3,drop_vs phi4)
- | CTL.EF(dir,phi) -> CTL.EF(dir,drop_vs phi)
- | CTL.EX(dir,phi) -> CTL.EX(dir,drop_vs phi)
- | CTL.EG(dir,phi) -> CTL.EG(dir,drop_vs phi)
- | CTL.EU(dir,phi1,phi2) -> CTL.EU(dir,drop_vs phi1,drop_vs phi2)
- | CTL.Ref(v) as x -> x
- | CTL.Let(v,term1,body) -> CTL.Let(v,drop_vs term1,drop_vs body))
-
-(* --------------------------------------------------------------------- *)
-
-let wrap n ctl = (ctl,n)
-
-let aftret =
- wrap 0 (CTL.Or(wrap 0 (CTL.Pred aftpred),wrap 0 (CTL.Pred exitpred)))
-
-let wrapImplies n (x,y) = wrap n (CTL.Implies(x,y))
-let wrapExists n (x,y) = wrap n (CTL.Exists(x,y))
-let wrapAnd n (x,y) = wrap n (CTL.And(x,y))
-let wrapOr n (x,y) = wrap n (CTL.Or(x,y))
-let wrapSeqOr n (x,y) = wrap n (CTL.SeqOr(x,y))
-let wrapAU n (x,y) = wrap n (CTL.AU(CTL.FORWARD,x,y,drop_vs x,drop_vs y))
-let wrapEU n (x,y) = wrap n (CTL.EU(CTL.FORWARD,x,y))
-let wrapAX n (x) = wrap n (CTL.AX(CTL.FORWARD,x))
-let wrapBackAX n (x) = wrap n (CTL.AX(CTL.BACKWARD,x))
-let wrapEX n (x) = wrap n (CTL.EX(CTL.FORWARD,x))
-let wrapBackEX n (x) = wrap n (CTL.EX(CTL.BACKWARD,x))
-let wrapAG n (x) = wrap n (CTL.AG(CTL.FORWARD,x))
-let wrapEG n (x) = wrap n (CTL.EG(CTL.FORWARD,x))
-let wrapAF n (x) = wrap n (CTL.AF(CTL.FORWARD,x,drop_vs x))
-let wrapEF n (x) = wrap n (CTL.EF(CTL.FORWARD,x))
-let wrapNot n (x) = wrap n (CTL.Not(x))
-let wrapPred n (x) = wrap n (CTL.Pred(x))
-let wrapLet n (x,y,z) = wrap n (CTL.Let(x,y,z))
-let wrapRef n (x) = wrap n (CTL.Ref(x))
-
-(* --------------------------------------------------------------------- *)
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-let get_list_option fn = function
- None -> []
- | Some x -> fn x
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Eliminate OptStm *)
-
-(* for optional thing with nothing after, should check that the optional thing
-never occurs. otherwise the matching stops before it occurs *)
-let elim_opt =
- let mcode x = x in
- let donothing r k e = k e in
-
- let fvlist l =
- List.fold_left Common.union_set [] (List.map Ast.get_fvs l) in
-
- let rec dots_list unwrapped wrapped =
- match (unwrapped,wrapped) with
- ([],_) -> []
-
- | (Ast.Dots(_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_) as u)::urest,
- d0::_::d1::rest)
- | (Ast.Nest(_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_) as u)::urest,
- d0::_::d1::rest) ->
- let l = Ast.get_line stm in
- let new_rest1 = stm :: (dots_list (u::urest) (d1::rest)) in
- let new_rest2 = dots_list urest rest in
- let fv_rest1 = fvlist new_rest1 in
- let fv_rest2 = fvlist new_rest2 in
- [d0;(Ast.Disj[(Ast.DOTS(new_rest1),l,fv_rest1,Ast.NoDots);
- (Ast.DOTS(new_rest2),l,fv_rest2,Ast.NoDots)],
- l,fv_rest1,Ast.NoDots)]
-
- | (Ast.OptStm(stm)::urest,_::rest) ->
- let l = Ast.get_line stm in
- let new_rest1 = dots_list urest rest in
- let new_rest2 = stm::new_rest1 in
- let fv_rest1 = fvlist new_rest1 in
- let fv_rest2 = fvlist new_rest2 in
- [(Ast.Disj[(Ast.DOTS(new_rest2),l,fv_rest2,Ast.NoDots);
- (Ast.DOTS(new_rest1),l,fv_rest1,Ast.NoDots)],
- l,fv_rest2,Ast.NoDots)]
-
- | ([Ast.Dots(_,_,_);Ast.OptStm(stm)],[d1;_]) ->
- let l = Ast.get_line stm in
- let fv_stm = Ast.get_fvs stm in
- let fv_d1 = Ast.get_fvs d1 in
- let fv_both = Common.union_set fv_stm fv_d1 in
- [d1;(Ast.Disj[(Ast.DOTS([stm]),l,fv_stm,Ast.NoDots);
- (Ast.DOTS([d1]),l,fv_d1,Ast.NoDots)],
- l,fv_both,Ast.NoDots)]
-
- | ([Ast.Nest(_,_,_);Ast.OptStm(stm)],[d1;_]) ->
- let l = Ast.get_line stm in
- let rw = Ast.rewrap stm in
- let rwd = Ast.rewrap stm in
- let dots =
- Ast.Dots(("...",{ Ast.line = 0; Ast.column = 0 },
- Ast.CONTEXT(Ast.NOTHING)),
- Ast.NoWhen,[]) in
- [d1;rw(Ast.Disj[rwd(Ast.DOTS([stm]));
- (Ast.DOTS([rw dots]),l,[],Ast.NoDots)])]
-
- | (_::urest,stm::rest) -> stm :: (dots_list urest rest)
- | _ -> failwith "not possible" in
-
- let stmtdotsfn r k d =
- let d = k d in
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(dots_list (List.map Ast.unwrap l) l)
- | Ast.CIRCLES(l) -> failwith "elimopt: not supported"
- | Ast.STARS(l) -> failwith "elimopt: not supported") in
-
- V.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing stmtdotsfn
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* Count depth of braces. The translation of a closed brace appears deeply
-nested within the translation of the sequence term, so the name of the
-paren var has to take into account the names of the nested braces. On the
-other hand the close brace does not escape, so we don't have to take into
-account other paren variable names. *)
-
-(* called repetitively, which is inefficient, but less trouble than adding a
-new field to Seq and FunDecl *)
-let count_nested_braces s =
- let bind x y = max x y in
- let option_default = 0 in
- let stmt_count r k s =
- match Ast.unwrap s with
- Ast.Seq(_,_,_,_,_) | Ast.FunDecl(_,_,_,_,_,_) -> (k s) + 1
- | _ -> k s in
- let donothing r k e = k e in
- let mcode r x = 0 in
- let recursor = V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing
- donothing donothing donothing donothing donothing donothing
- donothing stmt_count donothing donothing in
- "p"^(string_of_int (recursor.V.combiner_statement s))
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-let ctr = ref 0
-let fresh_var _ =
- let c = !ctr in
- (*ctr := !ctr + 1;*)
- Printf.sprintf "v%d" c
-
-let labctr = ref 0
-let fresh_label_var s =
- let c = !labctr in
- labctr := !labctr + 1;
- Printf.sprintf "%s%d" s c
-
-let lctr = ref 0
-let fresh_let_var _ =
- let c = !lctr in
- lctr := !lctr + 1;
- Printf.sprintf "l%d" c
-
-let sctr = ref 0
-let fresh_metavar _ =
- let c = !sctr in
-(*sctr := !sctr + 1;*)
- Printf.sprintf "_S%d" c
-
-let get_unquantified quantified vars =
- List.filter (function x -> not (List.mem x quantified)) vars
-
-type after = After of formula | Guard of formula | Tail
-
-let make_seq n l =
- let rec loop = function
- [] -> failwith "not possible"
- | [x] -> x
- | x::xs -> wrapAnd n (x,wrapAX n (loop xs)) in
- loop l
-
-let make_seq_after2 n first = function
- After rest -> wrapAnd n (first,wrapAX n (wrapAX n rest))
- | _ -> first
-
-let make_seq_after n first = function
- After rest -> make_seq n [first;rest]
- | _ -> first
-
-let a2n = function After f -> Guard f | x -> x
-
-let and_opt n first = function
- After rest -> wrapAnd n (first,rest)
- | _ -> first
-
-let contains_modif =
- let bind x y = x or y in
- let option_default = false in
- let mcode r (_,_,kind) =
- match kind with
- Ast.MINUS(_) -> true
- | Ast.PLUS -> failwith "not possible"
- | Ast.CONTEXT(info) -> not (info = Ast.NOTHING) in
- let do_nothing r k e = k e in
- let recursor =
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing in
- recursor.V.combiner_rule_elem
-
-let make_match n guard used_after code =
- if guard
- then wrapPred n (Lib_engine.Match(code),CTL.Control)
- else
- let v = fresh_var() in
- if contains_modif code
- then wrapExists n (v,wrapPred n (Lib_engine.Match(code),CTL.Modif v))
- else
- let any_used_after =
- List.exists (function x -> List.mem x used_after) (Ast.get_fvs code) in
- if !onlyModif && not any_used_after
- then wrapPred n (Lib_engine.Match(code),CTL.Control)
- else wrapExists n (v,wrapPred n (Lib_engine.Match(code),CTL.UnModif v))
-
-let make_raw_match n code = wrapPred n (Lib_engine.Match(code),CTL.Control)
-
-let rec seq_fvs quantified = function
- [] -> []
- | fv1::fvs ->
- let t1fvs = get_unquantified quantified fv1 in
- let termfvs =
- List.fold_left Common.union_set []
- (List.map (get_unquantified quantified) fvs) in
- let bothfvs = Common.inter_set t1fvs termfvs in
- let t1onlyfvs = Common.minus_set t1fvs bothfvs in
- let new_quantified = Common.union_set bothfvs quantified in
- (t1onlyfvs,bothfvs)::(seq_fvs new_quantified fvs)
-
-let seq_fvs2 quantified fv1 fv2 =
- match seq_fvs quantified [fv1;fv2] with
- [(t1fvs,bfvs);(t2fvs,[])] -> (t1fvs,bfvs,t2fvs)
- | _ -> failwith "impossible"
-
-let seq_fvs3 quantified fv1 fv2 fv3 =
- match seq_fvs quantified [fv1;fv2;fv3] with
- [(t1fvs,b12fvs);(t2fvs,b23fvs);(t3fvs,[])] ->
- (t1fvs,b12fvs,t2fvs,b23fvs,t3fvs)
- | _ -> failwith "impossible"
-
-let seq_fvs4 quantified fv1 fv2 fv3 fv4 =
- match seq_fvs quantified [fv1;fv2;fv3;fv4] with
- [(t1fvs,b12fvs);(t2fvs,b23fvs);(t3fvs,b34fvs);(t4fvs,[])] ->
- (t1fvs,b12fvs,t2fvs,b23fvs,t3fvs,b34fvs,t4fvs)
- | _ -> failwith "impossible"
-
-let seq_fvs5 quantified fv1 fv2 fv3 fv4 fv5 =
- match seq_fvs quantified [fv1;fv2;fv3;fv4;fv5] with
- [(t1fvs,b12fvs);(t2fvs,b23fvs);(t3fvs,b34fvs);(t4fvs,b45fvs);(t5fvs,[])] ->
- (t1fvs,b12fvs,t2fvs,b23fvs,t3fvs,b34fvs,t4fvs,b45fvs,t5fvs)
- | _ -> failwith "impossible"
-
-let quantify n =
- List.fold_right (function cur -> function code -> wrapExists n (cur,code))
-
-let intersectll lst nested_list =
- List.filter (function x -> List.exists (List.mem x) nested_list) lst
-
-(* --------------------------------------------------------------------- *)
-(* annotate dots with before and after neighbors *)
-
-let rec get_before sl a =
- match Ast.unwrap sl with
- Ast.DOTS(x) ->
- let rec loop sl a =
- match sl with
- [] -> ([],a)
- | e::sl ->
- let (e,ea) = get_before_e e a in
- let (sl,sla) = loop sl ea in
- (e::sl,sla) in
- let (l,a) = loop x a in
- (Ast.rewrap sl (Ast.DOTS(l)),a)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-and get_before_e s a =
- match Ast.unwrap s with
- Ast.Dots(d,Ast.NoWhen,t) ->
- (Ast.rewrap s (Ast.Dots(d,Ast.NoWhen,a@t)),a)
- | Ast.Dots(d,Ast.WhenNot w,t) ->
- let (w,_) = get_before w [] in
- (Ast.rewrap s (Ast.Dots(d,Ast.WhenNot w,a@t)),a)
- | Ast.Dots(d,Ast.WhenAlways w,t) ->
- let (w,_) = get_before_e w [] in
- (Ast.rewrap s (Ast.Dots(d,Ast.WhenAlways w,a@t)),a)
- | Ast.Nest(stmt_dots,w,t) ->
- let (w,_) = List.split (List.map (function s -> get_before s []) w) in
- let (sd,_) = get_before stmt_dots a in
- let a =
- List.filter
- (function
- Ast.Other a ->
- let unifies =
- Unify_ast.unify_statement_dots
- (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | Ast.Other_dots a ->
- let unifies = Unify_ast.unify_statement_dots a stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | _ -> true)
- a in
- (Ast.rewrap s (Ast.Nest(sd,w,a@t)),[Ast.Other_dots stmt_dots])
- | Ast.Disj(stmt_dots_list) ->
- let (dsl,dsla) =
- List.split (List.map (function e -> get_before e a) stmt_dots_list) in
- (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla)
- | Ast.Atomic(ast) ->
- (match Ast.unwrap ast with
- Ast.MetaStmt(_,_,_) -> (s,[])
- | _ -> (s,[Ast.Other s]))
- | Ast.Seq(lbrace,decls,dots,body,rbrace) ->
- let index = count_nested_braces s in
- let (de,dea) = get_before decls [Ast.WParen(lbrace,index)] in
- let (bd,_) = get_before body dea in
- (Ast.rewrap s (Ast.Seq(lbrace,de,dots,bd,rbrace)),
- [Ast.WParen(rbrace,index)])
- | Ast.IfThen(ifheader,branch,aft) ->
- let (br,_) = get_before_e branch [] in
- (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)), [Ast.Other s])
- | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) ->
- let (br1,_) = get_before_e branch1 [] in
- let (br2,_) = get_before_e branch2 [] in
- (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s])
- | Ast.While(header,body,aft) ->
- let (bd,_) = get_before_e body [] in
- (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s])
- | Ast.For(header,body,aft) ->
- let (bd,_) = get_before_e body [] in
- (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s])
- | Ast.FunDecl(header,lbrace,decls,dots,body,rbrace) ->
- let index = count_nested_braces s in
- let (de,dea) = get_before decls [Ast.WParen(lbrace,index)] in
- let (bd,_) = get_before body dea in
- (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,dots,bd,rbrace)),[])
- | _ -> failwith "not supported"
-
-let rec get_after sl a =
- match Ast.unwrap sl with
- Ast.DOTS(x) ->
- let rec loop sl =
- match sl with
- [] -> ([],a)
- | e::sl ->
- let (sl,sla) = loop sl in
- let (e,ea) = get_after_e e sla in
- (e::sl,ea) in
- let (l,a) = loop x in
- (Ast.rewrap sl (Ast.DOTS(l)),a)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-and get_after_e s a =
- match Ast.unwrap s with
- Ast.Dots(d,Ast.NoWhen,t) ->
- (Ast.rewrap s (Ast.Dots(d,Ast.NoWhen,a@t)),a)
- | Ast.Dots(d,Ast.WhenNot w,t) ->
- let (w,_) = get_after w [] in
- (Ast.rewrap s (Ast.Dots(d,Ast.WhenNot w,a@t)),a)
- | Ast.Dots(d,Ast.WhenAlways w,t) ->
- let (w,_) = get_after_e w [] in
- (Ast.rewrap s (Ast.Dots(d,Ast.WhenAlways w,a@t)),a)
- | Ast.Nest(stmt_dots,w,t) ->
- let (w,_) = List.split (List.map (function s -> get_after s []) w) in
- let (sd,_) = get_after stmt_dots a in
- let a =
- List.filter
- (function
- Ast.Other a ->
- let unifies =
- Unify_ast.unify_statement_dots
- (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | Ast.Other_dots a ->
- let unifies = Unify_ast.unify_statement_dots a stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | _ -> true)
- a in
- (Ast.rewrap s (Ast.Nest(sd,w,a@t)),[Ast.Other_dots stmt_dots])
- | Ast.Disj(stmt_dots_list) ->
- let (dsl,dsla) =
- List.split (List.map (function e -> get_after e a) stmt_dots_list) in
- (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla)
- | Ast.Atomic(ast) ->
- (match Ast.unwrap ast with
- Ast.MetaStmt(nm,Ast.SequencibleAfterDots _,i) ->
- (* check after information for metavar optimization *)
- (* if the error is not desired, could just return [], then
- the optimization (check for EF) won't take place *)
- List.iter
- (function
- Ast.Other x ->
- (match Ast.unwrap x with
- Ast.Dots(_,_,_) | Ast.Nest(_,_,_) ->
- failwith
- "dots/nest not allowed before and after stmt metavar"
- | _ -> ())
- | Ast.Other_dots x ->
- (match Ast.undots x with
- x::_ ->
- (match Ast.unwrap x with
- Ast.Dots(_,_,_) | Ast.Nest(_,_,_) ->
- failwith
- ("dots/nest not allowed before and after stmt "^
- "metavar")
- | _ -> ())
- | _ -> ())
- | _ -> ())
- a;
- (Ast.rewrap s
- (Ast.Atomic
- (Ast.rewrap s
- (Ast.MetaStmt(nm,Ast.SequencibleAfterDots a,i)))),[])
- | Ast.MetaStmt(_,_,_) -> (s,[])
- | _ -> (s,[Ast.Other s]))
- | Ast.Seq(lbrace,decls,dots,body,rbrace) ->
- let index = count_nested_braces s in
- let (bd,bda) = get_after body [Ast.WParen(rbrace,index)] in
- let (de,_) = get_after decls bda in
- (Ast.rewrap s (Ast.Seq(lbrace,de,dots,bd,rbrace)),
- [Ast.WParen(lbrace,index)])
- | Ast.IfThen(ifheader,branch,aft) ->
- let (br,_) = get_after_e branch a in
- (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)),[Ast.Other s])
- | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) ->
- let (br1,_) = get_after_e branch1 a in
- let (br2,_) = get_after_e branch2 a in
- (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s])
- | Ast.While(header,body,aft) ->
- let (bd,_) = get_after_e body a in
- (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s])
- | Ast.For(header,body,aft) ->
- let (bd,_) = get_after_e body a in
- (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s])
- | Ast.FunDecl(header,lbrace,decls,dots,body,rbrace) ->
- let index = count_nested_braces s in
- let (bd,bda) = get_after body [Ast.WParen(rbrace,index)] in
- let (de,_) = get_after decls bda in
- (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,dots,bd,rbrace)),[])
- | _ -> failwith "not supported"
-
-
-let preprocess_dots sl =
- let (sl,_) = get_before sl [] in
- let (sl,_) = get_after sl [] in
- sl
-
-let preprocess_dots_e sl =
- let (sl,_) = get_before_e sl [] in
- let (sl,_) = get_after_e sl [] in
- sl
-
-(* --------------------------------------------------------------------- *)
-(* the main translation loop *)
-
-let decl_to_not_decl n dots stmt make_match f =
- if dots
- then f
- else
- let de =
- let md = Ast.make_meta_decl "_d" (Ast.CONTEXT(Ast.NOTHING)) in
- Ast.rewrap md (Ast.Decl md) in
- wrapAU n (make_match de,
- wrap n (CTL.And(wrap n (CTL.Not (make_match de)), f)))
-
-let rec statement_list stmt_list used_after after quantified guard =
- let n = if !line_numbers then Ast.get_line stmt_list else 0 in
- match Ast.unwrap stmt_list with
- Ast.DOTS(x) ->
- let rec loop quantified = function
- ([],_) -> (match after with After f -> f | _ -> wrap n CTL.True)
- | ([e],_) -> statement e used_after after quantified guard
- | (e::sl,fv::fvs) ->
- let shared = intersectll fv fvs in
- let unqshared = get_unquantified quantified shared in
- let new_quantified = Common.union_set unqshared quantified in
- quantify n unqshared
- (statement e used_after (After(loop new_quantified (sl,fvs)))
- new_quantified guard)
- | _ -> failwith "not possible" in
- loop quantified (x,List.map Ast.get_fvs x)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-and statement stmt used_after after quantified guard =
-
- let n = if !line_numbers then Ast.get_line stmt else 0 in
- let wrapExists = wrapExists n in
- let wrapAnd = wrapAnd n in
- let wrapOr = wrapOr n in
- let wrapSeqOr = wrapSeqOr n in
- let wrapAU = wrapAU n in
- let wrapAX = wrapAX n in
- let wrapBackAX = wrapBackAX n in
- let wrapEX = wrapEX n in
- let wrapBackEX = wrapBackEX n in
- let wrapAG = wrapAG n in
- let wrapAF = wrapAF n in
- let wrapEF = wrapEF n in
- let wrapNot = wrapNot n in
- let wrapPred = wrapPred n in
- let make_seq = make_seq n in
- let make_seq_after2 = make_seq_after2 n in
- let make_seq_after = make_seq_after n in
- let and_opt = and_opt n in
- let quantify = quantify n in
- let make_match = make_match n guard used_after in
- let make_raw_match = make_raw_match n in
-
- let make_meta_rule_elem d =
- let nm = fresh_metavar() in
- Ast.make_meta_rule_elem nm d in
-
- match Ast.unwrap stmt with
- Ast.Atomic(ast) ->
- (match Ast.unwrap ast with
- Ast.MetaStmt((s,i,(Ast.CONTEXT(Ast.BEFOREAFTER(_,_)) as d)),seqible,_)
- | Ast.MetaStmt((s,i,(Ast.CONTEXT(Ast.AFTER(_)) as d)),seqible,_) ->
- let label_var = (*fresh_label_var*) "_lab" in
- let label_pred = wrapPred(Lib_engine.Label(label_var),CTL.Control) in
- let prelabel_pred =
- wrapPred(Lib_engine.PrefixLabel(label_var),CTL.Control) in
- let matcher d = make_match (make_meta_rule_elem d) in
- let full_metamatch = matcher d in
- let first_metamatch =
- matcher
- (match d with
- Ast.CONTEXT(Ast.BEFOREAFTER(bef,_)) ->
- Ast.CONTEXT(Ast.BEFORE(bef))
- | Ast.CONTEXT(_) -> Ast.CONTEXT(Ast.NOTHING)
- | Ast.MINUS(_) | Ast.PLUS -> failwith "not possible") in
- let middle_metamatch =
- matcher
- (match d with
- Ast.CONTEXT(_) -> Ast.CONTEXT(Ast.NOTHING)
- | Ast.MINUS(_) | Ast.PLUS -> failwith "not possible") in
- let last_metamatch =
- matcher
- (match d with
- Ast.CONTEXT(Ast.BEFOREAFTER(_,aft)) ->
- Ast.CONTEXT(Ast.AFTER(aft))
- | Ast.CONTEXT(_) -> d
- | Ast.MINUS(_) | Ast.PLUS -> failwith "not possible") in
-
- let left_or =
- make_seq
- [full_metamatch; and_opt (wrapNot(prelabel_pred)) after] in
- let right_or =
- make_seq
- [first_metamatch;
- wrapAU(middle_metamatch,
- make_seq
- [wrapAnd(last_metamatch,label_pred);
- and_opt (wrapNot(prelabel_pred)) after])] in
- let body f =
- wrapAnd(label_pred,
- f (wrapAnd(make_raw_match ast,
- wrapOr(left_or,right_or)))) in
- let id x = x in
- (match seqible with
- Ast.Sequencible | Ast.SequencibleAfterDots [] ->
- quantify (label_var::get_unquantified quantified [s])
- (body
- (function x ->
- (wrapAnd(wrapNot(wrapBackAX(label_pred)),x))))
- | Ast.SequencibleAfterDots l ->
- let afts =
- List.map (process_bef_aft Tail quantified used_after n) l in
- let ors =
- List.fold_left (function x -> function y -> wrapOr(x,y))
- (List.hd afts) (List.tl afts) in
- quantify (label_var::get_unquantified quantified [s])
- (wrapAnd(wrapEF(wrapAnd(ors,wrapBackAX(label_pred))),
- body
- (function x ->
- wrapAnd(wrapNot(wrapBackAX(label_pred)),x))))
- | Ast.NotSequencible ->
- quantify (label_var::get_unquantified quantified [s]) (body id))
-
- | Ast.MetaStmt((s,i,d),seqible,_) ->
- let label_var = (*fresh_label_var*) "_lab" in
- let label_pred = wrapPred(Lib_engine.Label(label_var),CTL.Control) in
- let prelabel_pred =
- wrapPred(Lib_engine.PrefixLabel(label_var),CTL.Control) in
- let matcher d = make_match (make_meta_rule_elem d) in
- let first_metamatch = matcher d in
- let rest_metamatch =
- matcher
- (match d with
- Ast.MINUS(_) -> Ast.MINUS([])
- | Ast.CONTEXT(_) -> Ast.CONTEXT(Ast.NOTHING)
- | Ast.PLUS -> failwith "not possible") in
- (* first_nodea and first_nodeb are separated here and above to
- improve let sharing - only first_nodea is unique to this site *)
- let first_nodeb = first_metamatch in
- let rest_nodes = wrapAnd(rest_metamatch,prelabel_pred) in
- let last_node = and_opt (wrapNot(prelabel_pred)) after in
- let body f =
- wrapAnd
- (label_pred,
- f (wrapAnd
- (make_raw_match ast,
- (make_seq
- [first_nodeb; wrapAU(rest_nodes,last_node)])))) in
- (match seqible with
- Ast.Sequencible | Ast.SequencibleAfterDots [] ->
- quantify (label_var::get_unquantified quantified [s])
- (body
- (function x -> wrapAnd(wrapNot(wrapBackAX(label_pred)),x)))
- | Ast.SequencibleAfterDots l ->
- let afts =
- List.map (process_bef_aft Tail quantified used_after n) l in
- let ors =
- List.fold_left (function x -> function y -> wrapOr(x,y))
- (List.hd afts) (List.tl afts) in
- quantify (label_var::get_unquantified quantified [s])
- (wrapAnd(wrapEF(wrapAnd(ors,wrapBackAX(label_pred))),
- body
- (function x ->
- wrapAnd(wrapNot(wrapBackAX(label_pred)),x))))
- | Ast.NotSequencible ->
- quantify (label_var::get_unquantified quantified [s])
- (body (function x -> x)))
- | _ ->
- let stmt_fvs = Ast.get_fvs stmt in
- let fvs = get_unquantified quantified stmt_fvs in
- let between_dots = Ast.get_dots_bef_aft stmt in
- let term = make_match ast in
- let term =
- match between_dots with
- Ast.BetweenDots brace_term ->
- (match Ast.unwrap brace_term with
- Ast.Atomic(brace_ast) ->
- let case1 =
- wrapAnd
- (wrapOr
- (wrapBackEX
- (wrapPred(Lib_engine.TrueBranch,CTL.Control)),
- wrapBackEX
- (wrapBackEX(wrapPred(Lib_engine.FalseBranch,
- CTL.Control)))),
- make_match brace_ast) in
- let case2 =
- wrapAnd
- (wrapNot
- (wrapOr
- (wrapBackEX
- (wrapPred(Lib_engine.TrueBranch,CTL.Control)),
- wrapBackEX
- (wrapBackEX(wrapPred(Lib_engine.FalseBranch,
- CTL.Control))))),
- term) in
- wrapOr(case1,case2)
- | _ -> failwith "not possible")
- | Ast.NoDots -> term in
- make_seq_after (quantify fvs term) after)
- | Ast.Seq(lbrace,decls,dots,body,rbrace) ->
- let (lbfvs,b1fvs,_,b2fvs,_,b3fvs,rbfvs) =
- seq_fvs4 quantified
- (Ast.get_fvs lbrace) (Ast.get_fvs decls)
- (Ast.get_fvs body) (Ast.get_fvs rbrace) in
- let v = count_nested_braces stmt in
- let paren_pred = wrapPred(Lib_engine.Paren v,CTL.Control) in
- let start_brace =
- wrapAnd(quantify lbfvs (make_match lbrace),paren_pred) in
- let end_brace =
- wrapAnd(quantify rbfvs (make_match rbrace),paren_pred) in
- let new_quantified2 =
- Common.union_set b1fvs (Common.union_set b2fvs quantified) in
- let new_quantified3 = Common.union_set b3fvs new_quantified2 in
- wrapExists
- (v,quantify b1fvs
- (make_seq
- [start_brace;
- quantify b2fvs
- (statement_list decls used_after
- (After
- (decl_to_not_decl n dots stmt make_match
- (quantify b3fvs
- (statement_list body used_after
- (After (make_seq_after end_brace after))
- new_quantified3 guard))))
- new_quantified2 guard)]))
- | Ast.IfThen(ifheader,branch,aft) ->
-
-(* "if (test) thn" becomes:
- if(test) & AX((TrueBranch & AX thn) v FallThrough v After)
-
- "if (test) thn; after" becomes:
- if(test) & AX((TrueBranch & AX thn) v FallThrough v (After & AXAX after))
- & EX After
-*)
-
- (* free variables *)
- let (efvs,bfvs,_) =
- seq_fvs2 quantified (Ast.get_fvs ifheader) (Ast.get_fvs branch) in
- let new_quantified = Common.union_set bfvs quantified in
- (* if header *)
- let if_header = quantify efvs (make_match ifheader) in
- (* then branch and after *)
- let true_branch =
- make_seq
- [wrapPred(Lib_engine.TrueBranch,CTL.Control);
- statement branch used_after (a2n after) new_quantified guard] in
- let fall_branch = wrapPred(Lib_engine.FallThrough,CTL.Control) in
- let after_pred = wrapPred(Lib_engine.After,CTL.Control) in
- let (aft_needed,after_branch) =
- match aft with
- Ast.CONTEXT(Ast.NOTHING) -> (false,make_seq_after2 after_pred after)
- | _ ->
- (true,
- make_seq_after after_pred
- (After
- (make_seq_after (make_match (make_meta_rule_elem aft))
- after))) in
- let or_cases = wrapOr(true_branch,wrapOr(fall_branch,after_branch)) in
- (* the code *)
- (match (after,aft_needed) with
- (After _,_) (* pattern doesn't end here *)
- | (_,true) (* + code added after *) ->
- quantify bfvs
- (wrapAnd (if_header, wrapAnd(wrapAX or_cases, wrapEX after_pred)))
- | _ -> quantify bfvs (wrapAnd(if_header, wrapAX or_cases)))
-
- | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) ->
-
-(* "if (test) thn else els" becomes:
- if(test) & AX((TrueBranch & AX thn) v
- (FalseBranch & AX (else & AX els)) v After)
- & EX FalseBranch
-
- "if (test) thn else els; after" becomes:
- if(test) & AX((TrueBranch & AX thn) v
- (FalseBranch & AX (else & AX els)) v
- (After & AXAX after))
- & EX FalseBranch
- & EX After
-
-
- Note that we rely on the well-formedness of C programs. For example, we
- do not use EX to check that there is at least one then branch, because
- there is always one. And we do not check that there is only one then or
- else branch, because these again are always the case in a well-formed C
- program. *)
- (* free variables *)
- let (e1fvs,b1fvs,s1fvs) =
- seq_fvs2 quantified (Ast.get_fvs ifheader) (Ast.get_fvs branch1) in
- let (e2fvs,b2fvs,s2fvs) =
- seq_fvs2 quantified (Ast.get_fvs ifheader) (Ast.get_fvs branch2) in
- let bothfvs =
- Common.union_set
- (Common.union_set b1fvs b2fvs)
- (Common.inter_set s1fvs s2fvs) in
- let exponlyfvs = Common.inter_set e1fvs e2fvs in
- let new_quantified = Common.union_set bothfvs quantified in
- (* if header *)
- let if_header = quantify exponlyfvs (make_match ifheader) in
- (* then and else branches *)
- let true_branch =
- make_seq
- [wrapPred(Lib_engine.TrueBranch,CTL.Control);
- statement branch1 used_after (a2n after) new_quantified guard] in
- let false_pred = wrapPred(Lib_engine.FalseBranch,CTL.Control) in
- let false_branch =
- make_seq
- [false_pred; make_match els;
- statement branch2 used_after (a2n after) new_quantified guard] in
- let after_pred = wrapPred(Lib_engine.After,CTL.Control) in
- let (aft_needed,after_branch) =
- match aft with
- Ast.CONTEXT(Ast.NOTHING) -> (false,make_seq_after2 after_pred after)
- | _ ->
- (true,
- make_seq_after after_pred
- (After
- (make_seq_after (make_match (make_meta_rule_elem aft))
- after))) in
- let or_cases = wrapOr(true_branch,wrapOr(false_branch,after_branch)) in
- (* the code *)
- (match (after,aft_needed) with
- (After _,_) (* pattern doesn't end here *)
- | (_,true) (* + code added after *) ->
- quantify bothfvs
- (wrapAnd
- (if_header,
- wrapAnd(wrapAX or_cases,
- wrapAnd(wrapEX false_pred,wrapEX after_pred))))
- | _ ->
- quantify bothfvs
- (wrapAnd (if_header, wrapAnd(wrapAX or_cases, wrapEX false_pred))))
-
- | Ast.While(header,body,aft) | Ast.For(header,body,aft) ->
- (* the translation in this case is similar to that of an if with no else *)
- (* free variables *)
- let (efvs,bfvs,_) =
- seq_fvs2 quantified (Ast.get_fvs header) (Ast.get_fvs body) in
- let new_quantified = Common.union_set bfvs quantified in
- (* if header *)
- let header = quantify efvs (make_match header) in
- let body =
- make_seq
- [wrapPred(Lib_engine.TrueBranch,CTL.Control);
- statement body used_after (a2n after) new_quantified guard] in
- let after_pred = wrapPred(Lib_engine.FallThrough,CTL.Control) in
- let (aft_needed,after_branch) =
- match aft with
- Ast.CONTEXT(Ast.NOTHING) -> (false,make_seq_after2 after_pred after)
- | _ ->
- (true,
- make_seq_after after_pred
- (After
- (make_seq_after (make_match (make_meta_rule_elem aft))
- after))) in
- let or_cases = wrapOr(body,after_branch) in
- (* the code *)
- (match (after,aft_needed) with
- (After _,_) (* pattern doesn't end here *)
- | (_,true) (* + code added after *) ->
- quantify bfvs
- (wrapAnd (header, wrapAnd(wrapAX or_cases, wrapEX after_pred)))
- | _ -> quantify bfvs (wrapAnd(header, wrapAX or_cases)))
-
- | Ast.Disj(stmt_dots_list) ->
- let processed =
- List.map
- (function x -> statement_list x used_after after quantified guard)
- stmt_dots_list in
- let rec loop = function
- [] -> wrap n CTL.True
- | [x] -> x
- | x::xs -> wrapSeqOr(x,loop xs) in
- loop processed
-(*
- let do_one e =
- statement_list e used_after (a2n after) quantified true in
- let add_nots l e =
- List.fold_left
- (function rest -> function cur -> wrapAnd(wrapNot(do_one cur),rest))
- e l in
- let process_one nots cur =
- match Ast.unwrap cur with
- Ast.DOTS(x::xs) ->
- let on = List.map (function x -> Ast.OrOther_dots x) nots in
- (match Ast.unwrap x with
- Ast.Dots(d,w,t) ->
- List.iter
- (function x ->
- Printf.printf "a not\n";
- Pretty_print_cocci.statement_dots x)
- nots;
- let cur =
- Ast.rewrap cur
- (Ast.DOTS((Ast.rewrap x (Ast.Dots(d,w,on@t)))::xs)) in
- statement_list cur used_after after quantified guard
- | Ast.Nest(sd,w,t) ->
- let cur =
- Ast.rewrap cur
- (Ast.DOTS((Ast.rewrap x (Ast.Nest(sd,w,on@t)))::xs)) in
- statement_list cur used_after after quantified guard
- | _ ->
- add_nots nots
- (statement_list cur used_after after quantified guard))
- | Ast.DOTS([]) ->
- add_nots nots
- (statement_list cur used_after after quantified guard)
- | _ -> failwith "CIRCLES, STARS not supported" in
- let rec loop after = function
- [] -> failwith "disj shouldn't be empty" (*wrap n CTL.False*)
- | [(nots,cur)] -> process_one nots cur
- | (nots,cur)::rest -> wrapOr(process_one nots cur, loop after rest) in
- loop after (preprocess_disj stmt_dots_list)
-*)
- | Ast.Nest(stmt_dots,whencode,befaft) ->
- let dots_pattern =
- statement_list stmt_dots used_after (a2n after) quantified guard in
- let udots_pattern =
- let whencodes =
- List.map
- (function sl ->
- statement_list sl used_after (a2n after) quantified true)
- whencode in
- List.fold_left (function rest -> function cur -> wrapOr(cur,rest))
- (statement_list stmt_dots used_after (a2n after) quantified true)
- whencodes in
- (match (after,guard&&(whencode=[])) with
- (After a,true) ->
- let nots =
- List.map (process_bef_aft after quantified used_after n) befaft in
- (match nots with
- [] -> wrapAF(wrapOr(a,aftret))
- | x::xs ->
- let left =
- wrapNot
- (List.fold_left
- (function rest -> function cur -> wrapOr(cur,rest))
- x xs) in
- wrapAU(left,wrapOr(a,aftret)))
- | (After a,false) ->
- let left = wrapOr(dots_pattern,wrapNot udots_pattern) in
- let nots =
- List.map (process_bef_aft after quantified used_after n) befaft in
- let left =
- match nots with
- [] -> left
- | x::xs ->
- wrapAnd
- (wrapNot
- (List.fold_left
- (function rest -> function cur -> wrapOr(cur,rest))
- x xs),
- left) in
- wrapAU(left,wrapOr(a,aftret))
- | (_,true) -> wrap n CTL.True
- | (_,false) -> wrapAG(wrapOr(dots_pattern,wrapNot udots_pattern)))
- | Ast.Dots((_,i,d),whencodes,t) ->
- let dot_code =
- match d with
- Ast.MINUS(_) ->
- (* no need for the fresh metavar, but ... is a bit wierd as a
- variable name *)
- Some(make_match (make_meta_rule_elem d))
- | _ -> None in
- let whencodes =
- (match whencodes with
- Ast.NoWhen -> []
- | Ast.WhenNot whencodes ->
- [wrapNot
- (statement_list whencodes used_after (a2n after) quantified
- true)]
- | Ast.WhenAlways s ->
- [statement s used_after (a2n after) quantified true]) @
- (List.map wrapNot
- (List.map (process_bef_aft after quantified used_after n) t)) in
- let phi2 =
- match whencodes with
- [] -> None
- | x::xs ->
- Some
- (List.fold_left
- (function rest -> function cur -> wrapAnd(cur,rest))
- x xs) in
- let phi3 =
- match (dot_code,phi2) with (* add - on dots, if any *)
- (None,None) -> None
- | (Some dotcode,None) -> Some dotcode
- | (None,Some whencode) -> Some whencode
- | (Some dotcode,Some whencode) -> Some(wrapAnd (dotcode,whencode)) in
- let exit = wrap n (CTL.Pred (Lib_engine.Exit,CTL.Control)) in
- (* add in the after code to make the result *)
- (match (after,phi3) with
- (Tail,Some whencode) -> wrapAU(whencode,wrapOr(exit,aftret))
- | (Tail,None) -> wrapAF(wrapOr(exit,aftret))
- | (After f,Some whencode) | (Guard f,Some whencode) ->
- wrapAU(whencode,wrapOr(f,aftret))
- | (After f,None) | (Guard f,None) -> wrapAF(wrapOr(f,aftret)))
- | Ast.FunDecl(header,lbrace,decls,dots,body,rbrace) ->
- let (hfvs,b1fvs,lbfvs,b2fvs,_,b3fvs,_,b4fvs,rbfvs) =
- seq_fvs5 quantified (Ast.get_fvs header) (Ast.get_fvs lbrace)
- (Ast.get_fvs decls) (Ast.get_fvs body) (Ast.get_fvs rbrace) in
- let function_header = quantify hfvs (make_match header) in
- let v = count_nested_braces stmt in
- let paren_pred = wrapPred(Lib_engine.Paren v,CTL.Control) in
- let start_brace =
- wrapAnd(quantify lbfvs (make_match lbrace),paren_pred) in
- let end_brace =
- let stripped_rbrace =
- match Ast.unwrap rbrace with
- Ast.SeqEnd((data,info,_)) ->
- Ast.rewrap rbrace
- (Ast.SeqEnd ((data,info,Ast.CONTEXT(Ast.NOTHING))))
- | _ -> failwith "unexpected close brace" in
- let exit = wrap n (CTL.Pred (Lib_engine.Exit,CTL.Control)) in
- let errorexit = wrap n (CTL.Pred (Lib_engine.ErrorExit,CTL.Control)) in
- wrapAnd(quantify rbfvs (make_match rbrace),
- wrapAU(make_match stripped_rbrace,
- wrapOr(exit,errorexit))) in
- let new_quantified3 =
- Common.union_set b1fvs
- (Common.union_set b2fvs (Common.union_set b3fvs quantified)) in
- let new_quantified4 = Common.union_set b4fvs new_quantified3 in
- quantify b1fvs
- (make_seq
- [function_header;
- wrapExists
- (v,
- (quantify b2fvs
- (make_seq
- [start_brace;
- quantify b3fvs
- (statement_list decls used_after
- (After
- (decl_to_not_decl n dots stmt
- make_match
- (quantify b4fvs
- (statement_list body used_after
- (After
- (make_seq_after end_brace after))
- new_quantified4 guard))))
- new_quantified3 guard)])))])
- | Ast.OptStm(stm) ->
- failwith "OptStm should have been compiled away\n";
- | Ast.UniqueStm(stm) ->
- failwith "arities not yet supported"
- | Ast.MultiStm(stm) ->
- failwith "arities not yet supported"
- | _ -> failwith "not supported"
-
-and process_bef_aft after quantified used_after ln = function
- Ast.WParen (re,n) ->
- let paren_pred = wrapPred ln (Lib_engine.Paren n,CTL.Control) in
- wrapAnd ln (make_raw_match ln re,paren_pred)
- | Ast.Other s -> statement s used_after (a2n after) quantified true
- | Ast.Other_dots d -> statement_list d used_after (a2n after) quantified true
- | Ast.OrOther_dots d -> statement_list d used_after Tail quantified true
-
-(* Returns a triple for each disj element. The first element of the triple is
-Some v if the triple element needs a name, and None otherwise. The second
-element is a list of names whose negations should be conjuncted with the
-term. The third element is the original term *)
-and (preprocess_disj :
- Ast.statement Ast.dots list ->
- (Ast.statement Ast.dots list * Ast.statement Ast.dots) list) =
- function
- [] -> []
- | [s] -> [([],s)]
- | cur::rest ->
- let template =
- List.map (function r -> Unify_ast.unify_statement_dots cur r) rest in
- let processed = preprocess_disj rest in
- if List.exists (function Unify_ast.MAYBE -> true | _ -> false) template
- then
- ([], cur) ::
- (List.map2
- (function ((nots,r) as x) ->
- function Unify_ast.MAYBE -> (cur::nots,r) | Unify_ast.NO -> x)
- processed template)
- else ([], cur) :: processed
-
-(* --------------------------------------------------------------------- *)
-(* Letify:
-Phase 1: Use a hash table to identify formulas that appear more than once.
-Phase 2: Replace terms by variables.
-Phase 3: Drop lets to the point as close as possible to the uses of their
-variables *)
-
-let formula_table =
- (Hashtbl.create(50) :
- ((cocci_predicate,string,Wrapper_ctl.info) CTL.generic_ctl,
- int ref (* count *) * string ref (* name *) * bool ref (* processed *))
- Hashtbl.t)
-
-let add_hash phi =
- let (cell,_,_) =
- try Hashtbl.find formula_table phi
- with Not_found ->
- let c = (ref 0,ref "",ref false) in
- Hashtbl.add formula_table phi c;
- c in
- cell := !cell + 1
-
-let rec collect_duplicates f =
- add_hash f;
- match CTL.unwrap f with
- CTL.False -> ()
- | CTL.True -> ()
- | CTL.Pred(p) -> ()
- | CTL.Not(phi) -> collect_duplicates phi
- | CTL.Exists(v,phi) -> collect_duplicates phi
- | CTL.And(phi1,phi2) -> collect_duplicates phi1; collect_duplicates phi2
- | CTL.Or(phi1,phi2) -> collect_duplicates phi1; collect_duplicates phi2
- | CTL.SeqOr(phi1,phi2) -> collect_duplicates phi1; collect_duplicates phi2
- | CTL.Implies(phi1,phi2) -> collect_duplicates phi1; collect_duplicates phi2
- | CTL.AF(_,phi1,phi2) -> collect_duplicates phi1; collect_duplicates phi2
- | CTL.AX(_,phi) -> collect_duplicates phi
- | CTL.AG(_,phi) -> collect_duplicates phi
- | CTL.AU(_,phi1,phi2,phi3,phi4) ->
- collect_duplicates phi1; collect_duplicates phi2;
- collect_duplicates phi3; collect_duplicates phi4
- | CTL.EF(_,phi) -> collect_duplicates phi
- | CTL.EX(_,phi) -> collect_duplicates phi
- | CTL.EG(_,phi) -> collect_duplicates phi
- | CTL.EU(_,phi1,phi2) -> collect_duplicates phi1; collect_duplicates phi2
- | CTL.Uncheck(phi) -> collect_duplicates phi
- | _ -> failwith "not possible"
-
-let assign_variables _ =
- Hashtbl.iter
- (function formula ->
- function (cell,str,_) -> if !cell > 1 then str := fresh_let_var())
- formula_table
-
-let rec replace_formulas dec f =
- let (ct,name,treated) = Hashtbl.find formula_table f in
- let real_ct = !ct - dec in
- if real_ct > 1
- then
- if not !treated
- then
- begin
- treated := true;
- let (acc,new_f) = replace_subformulas (dec + (real_ct - 1)) f in
- ((!name,new_f) :: acc, CTL.rewrap f (CTL.Ref !name))
- end
- else ([],CTL.rewrap f (CTL.Ref !name))
- else replace_subformulas dec f
-
-and replace_subformulas dec f =
- match CTL.unwrap f with
- CTL.False -> ([],f)
- | CTL.True -> ([],f)
- | CTL.Pred(p) -> ([],f)
- | CTL.Not(phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.Not(new_phi)))
- | CTL.Exists(v,phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.Exists(v,new_phi)))
- | CTL.And(phi1,phi2) ->
- let (acc1,new_phi1) = replace_formulas dec phi1 in
- let (acc2,new_phi2) = replace_formulas dec phi2 in
- (acc1@acc2,CTL.rewrap f (CTL.And(new_phi1,new_phi2)))
- | CTL.Or(phi1,phi2) ->
- let (acc1,new_phi1) = replace_formulas dec phi1 in
- let (acc2,new_phi2) = replace_formulas dec phi2 in
- (acc1@acc2,CTL.rewrap f (CTL.Or(new_phi1,new_phi2)))
- | CTL.SeqOr(phi1,phi2) ->
- let (acc1,new_phi1) = replace_formulas dec phi1 in
- let (acc2,new_phi2) = replace_formulas dec phi2 in
- (acc1@acc2,CTL.rewrap f (CTL.SeqOr(new_phi1,new_phi2)))
- | CTL.Implies(phi1,phi2) ->
- let (acc1,new_phi1) = replace_formulas dec phi1 in
- let (acc2,new_phi2) = replace_formulas dec phi2 in
- (acc1@acc2,CTL.rewrap f (CTL.Implies(new_phi1,new_phi2)))
- | CTL.AF(dir,phi1,phi2) ->
- let (acc,new_phi1) = replace_formulas dec phi1 in
- let (acc,new_phi2) = replace_formulas dec phi2 in
- (acc,CTL.rewrap f (CTL.AF(dir,new_phi1,new_phi2)))
- | CTL.AX(dir,phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.AX(dir,new_phi)))
- | CTL.AG(dir,phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.AG(dir,new_phi)))
- | CTL.AU(dir,phi1,phi2,phi3,phi4) ->
- let (acc1,new_phi1) = replace_formulas dec phi1 in
- let (acc2,new_phi2) = replace_formulas dec phi2 in
- let (acc3,new_phi3) = replace_formulas dec phi3 in
- let (acc4,new_phi4) = replace_formulas dec phi4 in
- (acc1@acc2@acc3@acc4,
- CTL.rewrap f (CTL.AU(dir,new_phi1,new_phi2,new_phi3,new_phi4)))
- | CTL.EF(dir,phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.EF(dir,new_phi)))
- | CTL.EX(dir,phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.EX(dir,new_phi)))
- | CTL.EG(dir,phi) ->
- let (acc,new_phi) = replace_formulas dec phi in
- (acc,CTL.rewrap f (CTL.EG(dir,new_phi)))
- | CTL.EU(dir,phi1,phi2) ->
- let (acc1,new_phi1) = replace_formulas dec phi1 in
- let (acc2,new_phi2) = replace_formulas dec phi2 in
- (acc1@acc2,CTL.rewrap f (CTL.EU(dir,new_phi1,new_phi2)))
- | _ -> failwith "not possible"
-
-let ctlfv_table =
- (Hashtbl.create(50) :
- ((cocci_predicate,string,Wrapper_ctl.info) CTL.generic_ctl,
- string list (* fvs *) *
- string list (* intersection of fvs of subterms *))
- Hashtbl.t)
-
-let rec ctl_fvs f =
- try let (fvs,_) = Hashtbl.find ctlfv_table f in fvs
- with Not_found ->
- let ((fvs,_) as res) =
- match CTL.unwrap f with
- CTL.False | CTL.True | CTL.Pred(_) -> ([],[])
- | CTL.Not(phi) | CTL.Exists(_,phi)
- | CTL.AX(_,phi) | CTL.AG(_,phi)
- | CTL.EF(_,phi) | CTL.EX(_,phi) | CTL.EG(_,phi) -> (ctl_fvs phi,[])
- | CTL.AU(_,phi1,phi2,phi3,phi4) ->
- let phi1fvs = ctl_fvs phi1 in
- let phi2fvs = ctl_fvs phi2 in
- (* phi3 has the same fvs as phi1 and phi4 as phi2 *)
- (Common.union_set phi1fvs phi2fvs,intersect phi1fvs phi2fvs)
- | CTL.And(phi1,phi2) | CTL.Or(phi1,phi2) | CTL.SeqOr(phi1,phi2)
- | CTL.Implies(phi1,phi2) | CTL.AF(_,phi1,phi2) | CTL.EU(_,phi1,phi2) ->
- let phi1fvs = ctl_fvs phi1 in
- let phi2fvs = ctl_fvs phi2 in
- (Common.union_set phi1fvs phi2fvs,intersect phi1fvs phi2fvs)
- | CTL.Ref(v) -> ([v],[v])
- | CTL.Let(v,term,body) ->
- let phi1fvs = ctl_fvs term in
- let phi2fvs = Common.minus_set (ctl_fvs body) [v] in
- (Common.union_set phi1fvs phi2fvs,intersect phi1fvs phi2fvs) in
- Hashtbl.add ctlfv_table f res;
- fvs
-
-let rev_order_bindings b =
- let b =
- List.map
- (function (nm,term) ->
- let (fvs,_) = Hashtbl.find ctlfv_table term in (nm,fvs,term))
- b in
- let rec loop bound = function
- [] -> []
- | unbound ->
- let (now_bound,still_unbound) =
- List.partition (function (_,fvs,_) -> subset fvs bound)
- unbound in
- let get_names = List.map (function (x,_,_) -> x) in
- now_bound @ (loop ((get_names now_bound) @ bound) still_unbound) in
- List.rev(loop [] b)
-
-let drop_bindings b f = (* innermost bindings first in b *)
- let process_binary f ffvs inter nm term fail =
- if List.mem nm inter
- then CTL.rewrap f (CTL.Let(nm,term,f))
- else CTL.rewrap f (fail()) in
- let find_fvs f =
- let _ = ctl_fvs f in Hashtbl.find ctlfv_table f in
- let rec drop_one nm term f =
- match CTL.unwrap f with
- CTL.False -> f
- | CTL.True -> f
- | CTL.Pred(p) -> f
- | CTL.Not(phi) -> CTL.rewrap f (CTL.Not(drop_one nm term phi))
- | CTL.Exists(v,phi) -> CTL.rewrap f (CTL.Exists(v,drop_one nm term phi))
- | CTL.And(phi1,phi2) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ -> CTL.And(drop_one nm term phi1,drop_one nm term phi2))
- | CTL.Or(phi1,phi2) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ -> CTL.Or(drop_one nm term phi1,drop_one nm term phi2))
- | CTL.SeqOr(phi1,phi2) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ ->
- CTL.SeqOr(drop_one nm term phi1,drop_one nm term phi2))
- | CTL.Implies(phi1,phi2) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ ->
- CTL.Implies(drop_one nm term phi1,drop_one nm term phi2))
- | CTL.AF(dir,phi1,phi2) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ ->
- CTL.AF(dir,drop_one nm term phi1,drop_one nm term phi2))
- | CTL.AX(dir,phi) ->
- CTL.rewrap f (CTL.AX(dir,drop_one nm term phi))
- | CTL.AG(dir,phi) -> CTL.rewrap f (CTL.AG(dir,drop_one nm term phi))
- | CTL.AU(dir,phi1,phi2,phi3,phi4) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ ->
- CTL.AU(dir,drop_one nm term phi1,drop_one nm term phi2,
- drop_one nm term phi3,drop_one nm term phi4))
- | CTL.EF(dir,phi) -> CTL.rewrap f (CTL.EF(dir,drop_one nm term phi))
- | CTL.EX(dir,phi) ->
- CTL.rewrap f (CTL.EX(dir,drop_one nm term phi))
- | CTL.EG(dir,phi) -> CTL.rewrap f (CTL.EG(dir,drop_one nm term phi))
- | CTL.EU(dir,phi1,phi2) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ ->
- CTL.EU(dir,drop_one nm term phi1,drop_one nm term phi2))
- | (CTL.Ref(v) as x) -> process_binary f [v] [v] nm term (function _ -> x)
- | CTL.Let(v,term1,body) ->
- let (ffvs,inter) = find_fvs f in
- process_binary f ffvs inter nm term
- (function _ ->
- CTL.Let(v,drop_one nm term term1,drop_one nm term body)) in
- List.fold_left
- (function processed -> function (nm,_,term) -> drop_one nm term processed)
- f b
-
-let letify f =
- failwith "this code should not be used!!!"(*;
- Hashtbl.clear formula_table;
- Hashtbl.clear ctlfv_table;
- (* create a count of the number of occurrences of each subformula *)
- collect_duplicates f;
- (* give names to things that appear more than once *)
- assign_variables();
- (* replace duplicated formulas by their variables *)
- let (bindings,new_f) = replace_formulas 0 f in
- (* collect fvs of terms in bindings and new_f *)
- List.iter (function f -> let _ = ctl_fvs f in ())
- (new_f::(List.map (function (_,term) -> term) bindings));
- (* sort bindings with uses before defs *)
- let bindings = rev_order_bindings bindings in
- (* insert bindings as lets into the formula *)
- let res = drop_bindings bindings new_f in
- res*)
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-
-let top_level used_after t =
- match Ast.unwrap t with
- Ast.DECL(decl) -> failwith "not supported decl"
- | Ast.INCLUDE(inc,s) ->
- (* no indication of whether inc or s is modified *)
- wrap 0 (CTL.Pred((Lib_engine.Include(inc,s),CTL.Control)))
- | Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo"
- | Ast.FUNCTION(stmt) ->
- (*Printf.printf "orig\n";
- Pretty_print_cocci.statement "" stmt;
- Format.print_newline();*)
- let unopt = elim_opt.V.rebuilder_statement stmt in
- (*Printf.printf "unopt\n";
- Pretty_print_cocci.statement "" unopt;
- Format.print_newline();*)
- let unopt = preprocess_dots_e unopt in
- (*letify*)
- (statement unopt used_after Tail [] false)
- | Ast.CODE(stmt_dots) ->
- let unopt = elim_opt.V.rebuilder_statement_dots stmt_dots in
- let unopt = preprocess_dots unopt in
- (*letify*)
- (statement_list unopt used_after Tail [] false)
- | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords"
-
-(* --------------------------------------------------------------------- *)
-(* Contains dots *)
-
-let contains_dots =
- let bind x y = x or y in
- let option_default = false in
- let mcode r x = false in
- let statement r k s =
- match Ast.unwrap s with Ast.Dots(_,_,_) -> true | _ -> k s in
- let continue r k e = k e in
- let stop r k e = false in
- let res =
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- continue continue continue
- stop stop stop stop stop stop stop statement continue continue in
- res.V.combiner_top_level
-
-(* --------------------------------------------------------------------- *)
-(* Entry points *)
-
-let asttoctl l used_after =
- ctr := 0;
- lctr := 0;
- sctr := 0;
- let l =
- List.filter
- (function t ->
- match Ast.unwrap t with Ast.ERRORWORDS(exps) -> false | _ -> true)
- l in
- List.map2 top_level used_after l
-
-let pp_cocci_predicate (pred,modif) =
- Pretty_print_engine.pp_predicate pred
-
-let cocci_predicate_to_string (pred,modif) =
- Pretty_print_engine.predicate_to_string pred
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* for MINUS and CONTEXT, pos is always None in this file *)
-(*search for require*)
-(* true = don't see all matched nodes, only modified ones *)
-let onlyModif = ref true(*false*)
-
-type ex = Exists | Forall | ReverseForall
-let exists = ref Forall
-
-module Ast = Ast_cocci
-module V = Visitor_ast
-module CTL = Ast_ctl
-
-let warning s = Printf.fprintf stderr "warning: %s\n" s
-
-type cocci_predicate = Lib_engine.predicate * Ast.meta_name Ast_ctl.modif
-type formula =
- (cocci_predicate,Ast.meta_name, Wrapper_ctl.info) Ast_ctl.generic_ctl
-
-let union = Common.union_set
-let intersect l1 l2 = List.filter (function x -> List.mem x l2) l1
-let subset l1 l2 = List.for_all (function x -> List.mem x l2) l1
-
-let foldl1 f xs = List.fold_left f (List.hd xs) (List.tl xs)
-let foldr1 f xs =
- let xs = List.rev xs in List.fold_left f (List.hd xs) (List.tl xs)
-
-let used_after = ref ([] : Ast.meta_name list)
-let guard_to_strict guard = if guard then CTL.NONSTRICT else CTL.STRICT
-
-let saved = ref ([] : Ast.meta_name list)
-
-let string2var x = ("",x)
-
-(* --------------------------------------------------------------------- *)
-(* predicates matching various nodes in the graph *)
-
-let ctl_and s x y =
- match (x,y) with
- (CTL.False,_) | (_,CTL.False) -> CTL.False
- | (CTL.True,a) | (a,CTL.True) -> a
- | _ -> CTL.And(s,x,y)
-
-let ctl_or x y =
- match (x,y) with
- (CTL.True,_) | (_,CTL.True) -> CTL.True
- | (CTL.False,a) | (a,CTL.False) -> a
- | _ -> CTL.Or(x,y)
-
-let ctl_or_fl x y =
- match (x,y) with
- (CTL.True,_) | (_,CTL.True) -> CTL.True
- | (CTL.False,a) | (a,CTL.False) -> a
- | _ -> CTL.Or(y,x)
-
-let ctl_seqor x y =
- match (x,y) with
- (CTL.True,_) | (_,CTL.True) -> CTL.True
- | (CTL.False,a) | (a,CTL.False) -> a
- | _ -> CTL.SeqOr(x,y)
-
-let ctl_not = function
- CTL.True -> CTL.False
- | CTL.False -> CTL.True
- | x -> CTL.Not(x)
-
-let ctl_ax s = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x ->
- match !exists with
- Exists -> CTL.EX(CTL.FORWARD,x)
- | Forall -> CTL.AX(CTL.FORWARD,s,x)
- | ReverseForall -> failwith "not supported"
-
-let ctl_ax_absolute s = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.AX(CTL.FORWARD,s,x)
-
-let ctl_ex = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.EX(CTL.FORWARD,x)
-
-(* This stays being AX even for sgrep_mode, because it is used to identify
-the structure of the term, not matching the pattern. *)
-let ctl_back_ax = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.AX(CTL.BACKWARD,CTL.NONSTRICT,x)
-
-let ctl_back_ex = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.EX(CTL.BACKWARD,x)
-
-let ctl_ef = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.EF(CTL.FORWARD,x)
-
-let ctl_ag s = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.AG(CTL.FORWARD,s,x)
-
-let ctl_au s x y =
- match (x,!exists) with
- (CTL.True,Exists) -> CTL.EF(CTL.FORWARD,y)
- | (CTL.True,Forall) -> CTL.AF(CTL.FORWARD,s,y)
- | (CTL.True,ReverseForall) -> failwith "not supported"
- | (_,Exists) -> CTL.EU(CTL.FORWARD,x,y)
- | (_,Forall) -> CTL.AU(CTL.FORWARD,s,x,y)
- | (_,ReverseForall) -> failwith "not supported"
-
-let ctl_anti_au s x y = (* only for ..., where the quantifier is changed *)
- CTL.XX
- (match (x,!exists) with
- (CTL.True,Exists) -> CTL.AF(CTL.FORWARD,s,y)
- | (CTL.True,Forall) -> CTL.EF(CTL.FORWARD,y)
- | (CTL.True,ReverseForall) -> failwith "not supported"
- | (_,Exists) -> CTL.AU(CTL.FORWARD,s,x,y)
- | (_,Forall) -> CTL.EU(CTL.FORWARD,x,y)
- | (_,ReverseForall) -> failwith "not supported")
-
-let ctl_uncheck = function
- CTL.True -> CTL.True
- | CTL.False -> CTL.False
- | x -> CTL.Uncheck x
-
-let label_pred_maker = function
- None -> CTL.True
- | Some (label_var,used) ->
- used := true;
- CTL.Pred(Lib_engine.PrefixLabel(label_var),CTL.Control)
-
-let bclabel_pred_maker = function
- None -> CTL.True
- | Some (label_var,used) ->
- used := true;
- CTL.Pred(Lib_engine.BCLabel(label_var),CTL.Control)
-
-let predmaker guard pred label =
- ctl_and (guard_to_strict guard) (CTL.Pred pred) (label_pred_maker label)
-
-let aftpred = predmaker false (Lib_engine.After, CTL.Control)
-let retpred = predmaker false (Lib_engine.Return, CTL.Control)
-let funpred = predmaker false (Lib_engine.FunHeader, CTL.Control)
-let toppred = predmaker false (Lib_engine.Top, CTL.Control)
-let exitpred = predmaker false (Lib_engine.ErrorExit, CTL.Control)
-let endpred = predmaker false (Lib_engine.Exit, CTL.Control)
-let gotopred = predmaker false (Lib_engine.Goto, CTL.Control)
-let inlooppred = predmaker false (Lib_engine.InLoop, CTL.Control)
-let truepred = predmaker false (Lib_engine.TrueBranch, CTL.Control)
-let falsepred = predmaker false (Lib_engine.FalseBranch, CTL.Control)
-let fallpred = predmaker false (Lib_engine.FallThrough, CTL.Control)
-
-let aftret label_var f = ctl_or (aftpred label_var) (exitpred label_var)
-
-let letctr = ref 0
-let get_let_ctr _ =
- let cur = !letctr in
- letctr := cur + 1;
- Printf.sprintf "r%d" cur
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Eliminate OptStm *)
-
-(* for optional thing with nothing after, should check that the optional thing
-never occurs. otherwise the matching stops before it occurs *)
-let elim_opt =
- let mcode x = x in
- let donothing r k e = k e in
-
- let fvlist l =
- List.fold_left Common.union_set [] (List.map Ast.get_fvs l) in
-
- let mfvlist l =
- List.fold_left Common.union_set [] (List.map Ast.get_mfvs l) in
-
- let freshlist l =
- List.fold_left Common.union_set [] (List.map Ast.get_fresh l) in
-
- let inheritedlist l =
- List.fold_left Common.union_set [] (List.map Ast.get_inherited l) in
-
- let savedlist l =
- List.fold_left Common.union_set [] (List.map Ast.get_saved l) in
-
- let varlists l =
- (fvlist l, mfvlist l, freshlist l, inheritedlist l, savedlist l) in
-
- let rec dots_list unwrapped wrapped =
- match (unwrapped,wrapped) with
- ([],_) -> []
-
- | (Ast.Dots(_,_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_,_) as u)::urest,
- d0::s::d1::rest)
- | (Ast.Nest(_,_,_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_,_) as u)::urest,
- d0::s::d1::rest) ->
- let l = Ast.get_line stm in
- let new_rest1 = stm :: (dots_list (u::urest) (d1::rest)) in
- let new_rest2 = dots_list urest rest in
- let (fv_rest1,mfv_rest1,fresh_rest1,inherited_rest1,s1) =
- varlists new_rest1 in
- let (fv_rest2,mfv_rest2,fresh_rest2,inherited_rest2,s2) =
- varlists new_rest2 in
- [d0;
- {(Ast.make_term
- (Ast.Disj
- [{(Ast.make_term(Ast.DOTS(new_rest1))) with
- Ast.node_line = l;
- Ast.free_vars = fv_rest1;
- Ast.minus_free_vars = mfv_rest1;
- Ast.fresh_vars = fresh_rest1;
- Ast.inherited = inherited_rest1;
- Ast.saved_witness = s1};
- {(Ast.make_term(Ast.DOTS(new_rest2))) with
- Ast.node_line = l;
- Ast.free_vars = fv_rest2;
- Ast.minus_free_vars = mfv_rest2;
- Ast.fresh_vars = fresh_rest2;
- Ast.inherited = inherited_rest2;
- Ast.saved_witness = s2}])) with
- Ast.node_line = l;
- Ast.free_vars = fv_rest1;
- Ast.minus_free_vars = mfv_rest1;
- Ast.fresh_vars = fresh_rest1;
- Ast.inherited = inherited_rest1;
- Ast.saved_witness = s1}]
-
- | (Ast.OptStm(stm)::urest,_::rest) ->
- let l = Ast.get_line stm in
- let new_rest1 = dots_list urest rest in
- let new_rest2 = stm::new_rest1 in
- let (fv_rest1,mfv_rest1,fresh_rest1,inherited_rest1,s1) =
- varlists new_rest1 in
- let (fv_rest2,mfv_rest2,fresh_rest2,inherited_rest2,s2) =
- varlists new_rest2 in
- [{(Ast.make_term
- (Ast.Disj
- [{(Ast.make_term(Ast.DOTS(new_rest2))) with
- Ast.node_line = l;
- Ast.free_vars = fv_rest2;
- Ast.minus_free_vars = mfv_rest2;
- Ast.fresh_vars = fresh_rest2;
- Ast.inherited = inherited_rest2;
- Ast.saved_witness = s2};
- {(Ast.make_term(Ast.DOTS(new_rest1))) with
- Ast.node_line = l;
- Ast.free_vars = fv_rest1;
- Ast.minus_free_vars = mfv_rest1;
- Ast.fresh_vars = fresh_rest1;
- Ast.inherited = inherited_rest1;
- Ast.saved_witness = s1}])) with
- Ast.node_line = l;
- Ast.free_vars = fv_rest2;
- Ast.minus_free_vars = mfv_rest2;
- Ast.fresh_vars = fresh_rest2;
- Ast.inherited = inherited_rest2;
- Ast.saved_witness = s2}]
-
- | ([Ast.Dots(_,_,_,_);Ast.OptStm(stm)],[d1;_]) ->
- let l = Ast.get_line stm in
- let fv_stm = Ast.get_fvs stm in
- let mfv_stm = Ast.get_mfvs stm in
- let fresh_stm = Ast.get_fresh stm in
- let inh_stm = Ast.get_inherited stm in
- let saved_stm = Ast.get_saved stm in
- let fv_d1 = Ast.get_fvs d1 in
- let mfv_d1 = Ast.get_mfvs d1 in
- let fresh_d1 = Ast.get_fresh d1 in
- let inh_d1 = Ast.get_inherited d1 in
- let saved_d1 = Ast.get_saved d1 in
- let fv_both = Common.union_set fv_stm fv_d1 in
- let mfv_both = Common.union_set mfv_stm mfv_d1 in
- let fresh_both = Common.union_set fresh_stm fresh_d1 in
- let inh_both = Common.union_set inh_stm inh_d1 in
- let saved_both = Common.union_set saved_stm saved_d1 in
- [d1;
- {(Ast.make_term
- (Ast.Disj
- [{(Ast.make_term(Ast.DOTS([stm]))) with
- Ast.node_line = l;
- Ast.free_vars = fv_stm;
- Ast.minus_free_vars = mfv_stm;
- Ast.fresh_vars = fresh_stm;
- Ast.inherited = inh_stm;
- Ast.saved_witness = saved_stm};
- {(Ast.make_term(Ast.DOTS([d1]))) with
- Ast.node_line = l;
- Ast.free_vars = fv_d1;
- Ast.minus_free_vars = mfv_d1;
- Ast.fresh_vars = fresh_d1;
- Ast.inherited = inh_d1;
- Ast.saved_witness = saved_d1}])) with
- Ast.node_line = l;
- Ast.free_vars = fv_both;
- Ast.minus_free_vars = mfv_both;
- Ast.fresh_vars = fresh_both;
- Ast.inherited = inh_both;
- Ast.saved_witness = saved_both}]
-
- | ([Ast.Nest(_,_,_,_,_);Ast.OptStm(stm)],[d1;_]) ->
- let l = Ast.get_line stm in
- let rw = Ast.rewrap stm in
- let rwd = Ast.rewrap stm in
- let dots = Ast.Dots(Ast.make_mcode "...",[],[],[]) in
- [d1;rw(Ast.Disj
- [rwd(Ast.DOTS([stm]));
- {(Ast.make_term(Ast.DOTS([rw dots])))
- with Ast.node_line = l}])]
-
- | (_::urest,stm::rest) -> stm :: (dots_list urest rest)
- | _ -> failwith "not possible" in
-
- let stmtdotsfn r k d =
- let d = k d in
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(dots_list (List.map Ast.unwrap l) l)
- | Ast.CIRCLES(l) -> failwith "elimopt: not supported"
- | Ast.STARS(l) -> failwith "elimopt: not supported") in
-
- V.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing stmtdotsfn donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* after management *)
-(* We need Guard for the following case:
-<...
- a
- <...
- b
- ...>
-...>
-foo();
-
-Here the inner <... b ...> should not go past foo. But foo is not the
-"after" of the body of the outer nest, because we don't want to search for
-it in the case where the body of the outer nest ends in something other
-than dots or a nest. *)
-
-(* what is the difference between tail and end??? *)
-
-type after = After of formula | Guard of formula | Tail | End | VeryEnd
-
-let a2n = function After x -> Guard x | a -> a
-
-let print_ctl x =
- let pp_pred (x,_) = Pretty_print_engine.pp_predicate x in
- let pp_meta (_,x) = Common.pp x in
- Pretty_print_ctl.pp_ctl (pp_pred,pp_meta) false x;
- Format.print_newline()
-
-let print_after = function
- After ctl -> Printf.printf "After:\n"; print_ctl ctl
- | Guard ctl -> Printf.printf "Guard:\n"; print_ctl ctl
- | Tail -> Printf.printf "Tail\n"
- | VeryEnd -> Printf.printf "Very End\n"
- | End -> Printf.printf "End\n"
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-let fresh_var _ = string2var "_v"
-let fresh_pos _ = string2var "_pos" (* must be a constant *)
-
-let fresh_metavar _ = "_S"
-
-(* fvinfo is going to end up being from the whole associated statement.
- it would be better if it were just the free variables in d, but free_vars.ml
- doesn't keep track of free variables on + code *)
-let make_meta_rule_elem d fvinfo =
- let nm = fresh_metavar() in
- Ast.make_meta_rule_elem nm d fvinfo
-
-let get_unquantified quantified vars =
- List.filter (function x -> not (List.mem x quantified)) vars
-
-let make_seq guard l =
- let s = guard_to_strict guard in
- foldr1 (function rest -> function cur -> ctl_and s cur (ctl_ax s rest)) l
-
-let make_seq_after2 guard first rest =
- let s = guard_to_strict guard in
- match rest with
- After rest -> ctl_and s first (ctl_ax s (ctl_ax s rest))
- | _ -> first
-
-let make_seq_after guard first rest =
- match rest with
- After rest -> make_seq guard [first;rest]
- | _ -> first
-
-let opt_and guard first rest =
- let s = guard_to_strict guard in
- match first with
- None -> rest
- | Some first -> ctl_and s first rest
-
-let and_after guard first rest =
- let s = guard_to_strict guard in
- match rest with After rest -> ctl_and s first rest | _ -> first
-
-let contains_modif =
- let bind x y = x or y in
- let option_default = false in
- let mcode r (_,_,kind,metapos) =
- match kind with
- Ast.MINUS(_,_) -> true
- | Ast.PLUS -> failwith "not possible"
- | Ast.CONTEXT(_,info) -> not (info = Ast.NOTHING) in
- let do_nothing r k e = k e in
- let rule_elem r k re =
- let res = k re in
- match Ast.unwrap re with
- Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) ->
- bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
- | Ast.Decl(bef,_,decl) -> bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
- | _ -> res in
- let recursor =
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in
- recursor.V.combiner_rule_elem
-
-let contains_pos =
- let bind x y = x or y in
- let option_default = false in
- let mcode r (_,_,kind,metapos) =
- match metapos with
- Ast.MetaPos(_,_,_,_,_) -> true
- | Ast.NoMetaPos -> false in
- let do_nothing r k e = k e in
- let rule_elem r k re =
- let res = k re in
- match Ast.unwrap re with
- Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) ->
- bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
- | Ast.Decl(bef,_,decl) -> bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
- | _ -> res in
- let recursor =
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in
- recursor.V.combiner_rule_elem
-
-(* code is not a DisjRuleElem *)
-let make_match label guard code =
- let v = fresh_var() in
- let matcher = Lib_engine.Match(code) in
- if contains_modif code && not guard
- then CTL.Exists(true,v,predmaker guard (matcher,CTL.Modif v) label)
- else
- let iso_info = !Flag.track_iso_usage && not (Ast.get_isos code = []) in
- (match (iso_info,!onlyModif,guard,
- intersect !used_after (Ast.get_fvs code)) with
- (false,true,_,[]) | (_,_,true,_) ->
- predmaker guard (matcher,CTL.Control) label
- | _ -> CTL.Exists(true,v,predmaker guard (matcher,CTL.UnModif v) label))
-
-let make_raw_match label guard code =
- predmaker guard (Lib_engine.Match(code),CTL.Control) label
-
-let rec seq_fvs quantified = function
- [] -> []
- | fv1::fvs ->
- let t1fvs = get_unquantified quantified fv1 in
- let termfvs =
- List.fold_left Common.union_set []
- (List.map (get_unquantified quantified) fvs) in
- let bothfvs = Common.inter_set t1fvs termfvs in
- let t1onlyfvs = Common.minus_set t1fvs bothfvs in
- let new_quantified = Common.union_set bothfvs quantified in
- (t1onlyfvs,bothfvs)::(seq_fvs new_quantified fvs)
-
-let quantify guard =
- List.fold_right
- (function cur ->
- function code -> CTL.Exists (not guard && List.mem cur !saved,cur,code))
-
-let non_saved_quantify =
- List.fold_right
- (function cur -> function code -> CTL.Exists (false,cur,code))
-
-let intersectll lst nested_list =
- List.filter (function x -> List.exists (List.mem x) nested_list) lst
-
-(* --------------------------------------------------------------------- *)
-(* Count depth of braces. The translation of a closed brace appears deeply
-nested within the translation of the sequence term, so the name of the
-paren var has to take into account the names of the nested braces. On the
-other hand the close brace does not escape, so we don't have to take into
-account other paren variable names. *)
-
-(* called repetitively, which is inefficient, but less trouble than adding a
-new field to Seq and FunDecl *)
-let count_nested_braces s =
- let bind x y = max x y in
- let option_default = 0 in
- let stmt_count r k s =
- match Ast.unwrap s with
- Ast.Seq(_,_,_,_) | Ast.FunDecl(_,_,_,_,_) -> (k s) + 1
- | _ -> k s in
- let donothing r k e = k e in
- let mcode r x = 0 in
- let recursor = V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing
- donothing donothing stmt_count donothing donothing donothing in
- let res = string_of_int (recursor.V.combiner_statement s) in
- string2var ("p"^res)
-
-let labelctr = ref 0
-let get_label_ctr _ =
- let cur = !labelctr in
- labelctr := cur + 1;
- string2var (Printf.sprintf "l%d" cur)
-
-(* --------------------------------------------------------------------- *)
-(* annotate dots with before and after neighbors *)
-
-let print_bef_aft = function
- Ast.WParen (re,n) ->
- Printf.printf "bef/aft\n";
- Pretty_print_cocci.rule_elem "" re;
- Format.print_newline()
- | Ast.Other s ->
- Printf.printf "bef/aft\n";
- Pretty_print_cocci.statement "" s;
- Format.print_newline()
- | Ast.Other_dots d ->
- Printf.printf "bef/aft\n";
- Pretty_print_cocci.statement_dots d;
- Format.print_newline()
-
-(* [] can only occur if we are in a disj, where it comes from a ? In that
-case, we want to use a, which accumulates all of the previous patterns in
-their entirety. *)
-let rec get_before_elem sl a =
- match Ast.unwrap sl with
- Ast.DOTS(x) ->
- let rec loop sl a =
- match sl with
- [] -> ([],Common.Right a)
- | [e] ->
- let (e,ea) = get_before_e e a in
- ([e],Common.Left ea)
- | e::sl ->
- let (e,ea) = get_before_e e a in
- let (sl,sla) = loop sl ea in
- (e::sl,sla) in
- let (l,a) = loop x a in
- (Ast.rewrap sl (Ast.DOTS(l)),a)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-and get_before sl a =
- match get_before_elem sl a with
- (term,Common.Left x) -> (term,x)
- | (term,Common.Right x) -> (term,x)
-
-and get_before_whencode wc =
- List.map
- (function
- Ast.WhenNot w -> let (w,_) = get_before w [] in Ast.WhenNot w
- | Ast.WhenAlways w -> let (w,_) = get_before_e w [] in Ast.WhenAlways w
- | Ast.WhenModifier(x) -> Ast.WhenModifier(x)
- | Ast.WhenNotTrue w -> Ast.WhenNotTrue w
- | Ast.WhenNotFalse w -> Ast.WhenNotFalse w)
- wc
-
-and get_before_e s a =
- match Ast.unwrap s with
- Ast.Dots(d,w,_,aft) ->
- (Ast.rewrap s (Ast.Dots(d,get_before_whencode w,a,aft)),a)
- | Ast.Nest(stmt_dots,w,multi,_,aft) ->
- let w = get_before_whencode w in
- let (sd,_) = get_before stmt_dots a in
- let a =
- List.filter
- (function
- Ast.Other a ->
- let unifies =
- Unify_ast.unify_statement_dots
- (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | Ast.Other_dots a ->
- let unifies = Unify_ast.unify_statement_dots a stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | _ -> true)
- a in
- (Ast.rewrap s (Ast.Nest(sd,w,multi,a,aft)),[Ast.Other_dots stmt_dots])
- | Ast.Disj(stmt_dots_list) ->
- let (dsl,dsla) =
- List.split (List.map (function e -> get_before e a) stmt_dots_list) in
- (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla)
- | Ast.Atomic(ast) ->
- (match Ast.unwrap ast with
- Ast.MetaStmt(_,_,_,_) -> (s,[])
- | _ -> (s,[Ast.Other s]))
- | Ast.Seq(lbrace,decls,body,rbrace) ->
- let index = count_nested_braces s in
- let (de,dea) = get_before decls [Ast.WParen(lbrace,index)] in
- let (bd,_) = get_before body dea in
- (Ast.rewrap s (Ast.Seq(lbrace,de,bd,rbrace)),
- [Ast.WParen(rbrace,index)])
- | Ast.Define(header,body) ->
- let (body,_) = get_before body [] in
- (Ast.rewrap s (Ast.Define(header,body)), [Ast.Other s])
- | Ast.IfThen(ifheader,branch,aft) ->
- let (br,_) = get_before_e branch [] in
- (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)), [Ast.Other s])
- | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) ->
- let (br1,_) = get_before_e branch1 [] in
- let (br2,_) = get_before_e branch2 [] in
- (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s])
- | Ast.While(header,body,aft) ->
- let (bd,_) = get_before_e body [] in
- (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s])
- | Ast.For(header,body,aft) ->
- let (bd,_) = get_before_e body [] in
- (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s])
- | Ast.Do(header,body,tail) ->
- let (bd,_) = get_before_e body [] in
- (Ast.rewrap s (Ast.Do(header,bd,tail)),[Ast.Other s])
- | Ast.Iterator(header,body,aft) ->
- let (bd,_) = get_before_e body [] in
- (Ast.rewrap s (Ast.Iterator(header,bd,aft)),[Ast.Other s])
- | Ast.Switch(header,lb,cases,rb) ->
- let cases =
- List.map
- (function case_line ->
- match Ast.unwrap case_line with
- Ast.CaseLine(header,body) ->
- let (body,_) = get_before body [] in
- Ast.rewrap case_line (Ast.CaseLine(header,body))
- | Ast.OptCase(case_line) -> failwith "not supported")
- cases in
- (Ast.rewrap s (Ast.Switch(header,lb,cases,rb)),[Ast.Other s])
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- let (de,dea) = get_before decls [] in
- let (bd,_) = get_before body dea in
- (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[])
- | _ ->
- Pretty_print_cocci.statement "" s; Format.print_newline();
- failwith "get_before_e: not supported"
-
-let rec get_after sl a =
- match Ast.unwrap sl with
- Ast.DOTS(x) ->
- let rec loop sl =
- match sl with
- [] -> ([],a)
- | e::sl ->
- let (sl,sla) = loop sl in
- let (e,ea) = get_after_e e sla in
- (e::sl,ea) in
- let (l,a) = loop x in
- (Ast.rewrap sl (Ast.DOTS(l)),a)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-and get_after_whencode a wc =
- List.map
- (function
- Ast.WhenNot w -> let (w,_) = get_after w a (*?*) in Ast.WhenNot w
- | Ast.WhenAlways w -> let (w,_) = get_after_e w a in Ast.WhenAlways w
- | Ast.WhenModifier(x) -> Ast.WhenModifier(x)
- | Ast.WhenNotTrue w -> Ast.WhenNotTrue w
- | Ast.WhenNotFalse w -> Ast.WhenNotFalse w)
- wc
-
-and get_after_e s a =
- match Ast.unwrap s with
- Ast.Dots(d,w,bef,_) ->
- (Ast.rewrap s (Ast.Dots(d,get_after_whencode a w,bef,a)),a)
- | Ast.Nest(stmt_dots,w,multi,bef,_) ->
- let w = get_after_whencode a w in
- let (sd,_) = get_after stmt_dots a in
- let a =
- List.filter
- (function
- Ast.Other a ->
- let unifies =
- Unify_ast.unify_statement_dots
- (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | Ast.Other_dots a ->
- let unifies = Unify_ast.unify_statement_dots a stmt_dots in
- (match unifies with
- Unify_ast.MAYBE -> false
- | _ -> true)
- | _ -> true)
- a in
- (Ast.rewrap s (Ast.Nest(sd,w,multi,bef,a)),[Ast.Other_dots stmt_dots])
- | Ast.Disj(stmt_dots_list) ->
- let (dsl,dsla) =
- List.split (List.map (function e -> get_after e a) stmt_dots_list) in
- (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla)
- | Ast.Atomic(ast) ->
- (match Ast.unwrap ast with
- Ast.MetaStmt(nm,keep,Ast.SequencibleAfterDots _,i) ->
- (* check "after" information for metavar optimization *)
- (* if the error is not desired, could just return [], then
- the optimization (check for EF) won't take place *)
- List.iter
- (function
- Ast.Other x ->
- (match Ast.unwrap x with
- Ast.Dots(_,_,_,_) | Ast.Nest(_,_,_,_,_) ->
- failwith
- "dots/nest not allowed before and after stmt metavar"
- | _ -> ())
- | Ast.Other_dots x ->
- (match Ast.undots x with
- x::_ ->
- (match Ast.unwrap x with
- Ast.Dots(_,_,_,_) | Ast.Nest(_,_,_,_,_) ->
- failwith
- ("dots/nest not allowed before and after stmt "^
- "metavar")
- | _ -> ())
- | _ -> ())
- | _ -> ())
- a;
- (Ast.rewrap s
- (Ast.Atomic
- (Ast.rewrap s
- (Ast.MetaStmt(nm,keep,Ast.SequencibleAfterDots a,i)))),[])
- | Ast.MetaStmt(_,_,_,_) -> (s,[])
- | _ -> (s,[Ast.Other s]))
- | Ast.Seq(lbrace,decls,body,rbrace) ->
- let index = count_nested_braces s in
- let (bd,bda) = get_after body [Ast.WParen(rbrace,index)] in
- let (de,_) = get_after decls bda in
- (Ast.rewrap s (Ast.Seq(lbrace,de,bd,rbrace)),
- [Ast.WParen(lbrace,index)])
- | Ast.Define(header,body) ->
- let (body,_) = get_after body a in
- (Ast.rewrap s (Ast.Define(header,body)), [Ast.Other s])
- | Ast.IfThen(ifheader,branch,aft) ->
- let (br,_) = get_after_e branch a in
- (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)),[Ast.Other s])
- | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) ->
- let (br1,_) = get_after_e branch1 a in
- let (br2,_) = get_after_e branch2 a in
- (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s])
- | Ast.While(header,body,aft) ->
- let (bd,_) = get_after_e body a in
- (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s])
- | Ast.For(header,body,aft) ->
- let (bd,_) = get_after_e body a in
- (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s])
- | Ast.Do(header,body,tail) ->
- let (bd,_) = get_after_e body a in
- (Ast.rewrap s (Ast.Do(header,bd,tail)),[Ast.Other s])
- | Ast.Iterator(header,body,aft) ->
- let (bd,_) = get_after_e body a in
- (Ast.rewrap s (Ast.Iterator(header,bd,aft)),[Ast.Other s])
- | Ast.Switch(header,lb,cases,rb) ->
- let cases =
- List.map
- (function case_line ->
- match Ast.unwrap case_line with
- Ast.CaseLine(header,body) ->
- let (body,_) = get_after body [] in
- Ast.rewrap case_line (Ast.CaseLine(header,body))
- | Ast.OptCase(case_line) -> failwith "not supported")
- cases in
- (Ast.rewrap s (Ast.Switch(header,lb,cases,rb)),[Ast.Other s])
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- let (bd,bda) = get_after body [] in
- let (de,_) = get_after decls bda in
- (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[])
- | _ -> failwith "get_after_e: not supported"
-
-let preprocess_dots sl =
- let (sl,_) = get_before sl [] in
- let (sl,_) = get_after sl [] in
- sl
-
-let preprocess_dots_e sl =
- let (sl,_) = get_before_e sl [] in
- let (sl,_) = get_after_e sl [] in
- sl
-
-(* --------------------------------------------------------------------- *)
-(* various return_related things *)
-
-let rec ends_in_return stmt_list =
- match Ast.unwrap stmt_list with
- Ast.DOTS(x) ->
- (match List.rev x with
- x::_ ->
- (match Ast.unwrap x with
- Ast.Atomic(x) ->
- let rec loop x =
- match Ast.unwrap x with
- Ast.Return(_,_) | Ast.ReturnExpr(_,_,_) -> true
- | Ast.DisjRuleElem((_::_) as l) -> List.for_all loop l
- | _ -> false in
- loop x
- | Ast.Disj(disjs) -> List.for_all ends_in_return disjs
- | _ -> false)
- | _ -> false)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-(* --------------------------------------------------------------------- *)
-(* expressions *)
-
-let exptymatch l make_match make_guard_match =
- let pos = fresh_pos() in
- let matches_guard_matches =
- List.map
- (function x ->
- let pos = Ast.make_mcode pos in
- (make_match (Ast.set_pos x (Some pos)),
- make_guard_match (Ast.set_pos x (Some pos))))
- l in
- let (matches,guard_matches) = List.split matches_guard_matches in
- let rec suffixes = function
- [] -> []
- | x::xs -> xs::(suffixes xs) in
- let prefixes = List.rev (suffixes (List.rev guard_matches)) in
- let info = (* not null *)
- List.map2
- (function matcher ->
- function negates ->
- CTL.Exists
- (false,pos,
- ctl_and CTL.NONSTRICT matcher
- (ctl_not
- (ctl_uncheck (List.fold_left ctl_or_fl CTL.False negates)))))
- matches prefixes in
- CTL.InnerAnd(List.fold_left ctl_or_fl CTL.False (List.rev info))
-
-(* code might be a DisjRuleElem, in which case we break it apart
- code might contain an Exp or Ty
- this one pushes the quantifier inwards *)
-let do_re_matches label guard res quantified minus_quantified =
- let make_guard_match x =
- let stmt_fvs = Ast.get_mfvs x in
- let fvs = get_unquantified minus_quantified stmt_fvs in
- non_saved_quantify fvs (make_match None true x) in
- let make_match x =
- let stmt_fvs = Ast.get_fvs x in
- let fvs = get_unquantified quantified stmt_fvs in
- quantify guard fvs (make_match None guard x) in
- ctl_and CTL.NONSTRICT (label_pred_maker label)
- (match List.map Ast.unwrap res with
- [] -> failwith "unexpected empty disj"
- | Ast.Exp(e)::rest -> exptymatch res make_match make_guard_match
- | Ast.Ty(t)::rest -> exptymatch res make_match make_guard_match
- | all ->
- if List.exists (function Ast.Exp(_) | Ast.Ty(_) -> true | _ -> false)
- all
- then failwith "unexpected exp or ty";
- List.fold_left ctl_seqor CTL.False
- (List.rev (List.map make_match res)))
-
-(* code might be a DisjRuleElem, in which case we break it apart
- code doesn't contain an Exp or Ty
- this one is for use when it is not practical to push the quantifier inwards
- *)
-let header_match label guard code : ('a, Ast.meta_name, 'b) CTL.generic_ctl =
- match Ast.unwrap code with
- Ast.DisjRuleElem(res) ->
- let make_match = make_match None guard in
- let orop = if guard then ctl_or else ctl_seqor in
- ctl_and CTL.NONSTRICT (label_pred_maker label)
- (List.fold_left orop CTL.False (List.map make_match res))
- | _ -> make_match label guard code
-
-(* --------------------------------------------------------------------- *)
-(* control structures *)
-
-let end_control_structure fvs header body after_pred
- after_checks no_after_checks (afvs,afresh,ainh,aft) after label guard =
- (* aft indicates what is added after the whole if, which has to be added
- to the endif node *)
- let (aft_needed,after_branch) =
- match aft with
- Ast.CONTEXT(_,Ast.NOTHING) ->
- (false,make_seq_after2 guard after_pred after)
- | _ ->
- let match_endif =
- make_match label guard
- (make_meta_rule_elem aft (afvs,afresh,ainh)) in
- (true,
- make_seq_after guard after_pred
- (After(make_seq_after guard match_endif after))) in
- let body = body after_branch in
- let s = guard_to_strict guard in
- (* the code *)
- quantify guard fvs
- (ctl_and s header
- (opt_and guard
- (match (after,aft_needed) with
- (After _,_) (* pattern doesn't end here *)
- | (_,true) (* + code added after *) -> after_checks
- | _ -> no_after_checks)
- (ctl_ax_absolute s body)))
-
-let ifthen ifheader branch ((afvs,_,_,_) as aft) after
- quantified minus_quantified label llabel slabel recurse make_match guard =
-(* "if (test) thn" becomes:
- if(test) & AX((TrueBranch & AX thn) v FallThrough v After)
-
- "if (test) thn; after" becomes:
- if(test) & AX((TrueBranch & AX thn) v FallThrough v (After & AXAX after))
- & EX After
-*)
- (* free variables *)
- let (efvs,bfvs) =
- match seq_fvs quantified
- [Ast.get_fvs ifheader;Ast.get_fvs branch;afvs] with
- [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs)
- | _ -> failwith "not possible" in
- let new_quantified = Common.union_set bfvs quantified in
- let (mefvs,mbfvs) =
- match seq_fvs minus_quantified
- [Ast.get_mfvs ifheader;Ast.get_mfvs branch;[]] with
- [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs)
- | _ -> failwith "not possible" in
- let new_mquantified = Common.union_set mbfvs minus_quantified in
- (* if header *)
- let if_header = quantify guard efvs (make_match ifheader) in
- (* then branch and after *)
- let lv = get_label_ctr() in
- let used = ref false in
- let true_branch =
- make_seq guard
- [truepred label; recurse branch Tail new_quantified new_mquantified
- (Some (lv,used)) llabel slabel guard] in
- let after_pred = aftpred label in
- let or_cases after_branch =
- ctl_or true_branch (ctl_or (fallpred label) after_branch) in
- let (if_header,wrapper) =
- if !used
- then
- let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in
- (ctl_and CTL.NONSTRICT(*???*) if_header label_pred,
- (function body -> quantify true [lv] body))
- else (if_header,function x -> x) in
- wrapper
- (end_control_structure bfvs if_header or_cases after_pred
- (Some(ctl_ex after_pred)) None aft after label guard)
-
-let ifthenelse ifheader branch1 els branch2 ((afvs,_,_,_) as aft) after
- quantified minus_quantified label llabel slabel recurse make_match guard =
-(* "if (test) thn else els" becomes:
- if(test) & AX((TrueBranch & AX thn) v
- (FalseBranch & AX (else & AX els)) v After)
- & EX FalseBranch
-
- "if (test) thn else els; after" becomes:
- if(test) & AX((TrueBranch & AX thn) v
- (FalseBranch & AX (else & AX els)) v
- (After & AXAX after))
- & EX FalseBranch
- & EX After
-*)
- (* free variables *)
- let (e1fvs,b1fvs,s1fvs) =
- match seq_fvs quantified
- [Ast.get_fvs ifheader;Ast.get_fvs branch1;afvs] with
- [(e1fvs,b1fvs);(s1fvs,b1afvs);_] ->
- (e1fvs,Common.union_set b1fvs b1afvs,s1fvs)
- | _ -> failwith "not possible" in
- let (e2fvs,b2fvs,s2fvs) =
- (* fvs on else? *)
- match seq_fvs quantified
- [Ast.get_fvs ifheader;Ast.get_fvs branch2;afvs] with
- [(e2fvs,b2fvs);(s2fvs,b2afvs);_] ->
- (e2fvs,Common.union_set b2fvs b2afvs,s2fvs)
- | _ -> failwith "not possible" in
- let bothfvs = union (union b1fvs b2fvs) (intersect s1fvs s2fvs) in
- let exponlyfvs = intersect e1fvs e2fvs in
- let new_quantified = union bothfvs quantified in
- (* minus free variables *)
- let (me1fvs,mb1fvs,ms1fvs) =
- match seq_fvs minus_quantified
- [Ast.get_mfvs ifheader;Ast.get_mfvs branch1;[]] with
- [(e1fvs,b1fvs);(s1fvs,b1afvs);_] ->
- (e1fvs,Common.union_set b1fvs b1afvs,s1fvs)
- | _ -> failwith "not possible" in
- let (me2fvs,mb2fvs,ms2fvs) =
- (* fvs on else? *)
- match seq_fvs minus_quantified
- [Ast.get_mfvs ifheader;Ast.get_mfvs branch2;[]] with
- [(e2fvs,b2fvs);(s2fvs,b2afvs);_] ->
- (e2fvs,Common.union_set b2fvs b2afvs,s2fvs)
- | _ -> failwith "not possible" in
- let mbothfvs = union (union mb1fvs mb2fvs) (intersect ms1fvs ms2fvs) in
- let new_mquantified = union mbothfvs minus_quantified in
- (* if header *)
- let if_header = quantify guard exponlyfvs (make_match ifheader) in
- (* then and else branches *)
- let lv = get_label_ctr() in
- let used = ref false in
- let true_branch =
- make_seq guard
- [truepred label; recurse branch1 Tail new_quantified new_mquantified
- (Some (lv,used)) llabel slabel guard] in
- let false_branch =
- make_seq guard
- [falsepred label; make_match els;
- recurse branch2 Tail new_quantified new_mquantified
- (Some (lv,used)) llabel slabel guard] in
- let after_pred = aftpred label in
- let or_cases after_branch =
- ctl_or true_branch (ctl_or false_branch after_branch) in
- let s = guard_to_strict guard in
- let (if_header,wrapper) =
- if !used
- then
- let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in
- (ctl_and CTL.NONSTRICT(*???*) if_header label_pred,
- (function body -> quantify true [lv] body))
- else (if_header,function x -> x) in
- wrapper
- (end_control_structure bothfvs if_header or_cases after_pred
- (Some(ctl_and s (ctl_ex (falsepred label)) (ctl_ex after_pred)))
- (Some(ctl_ex (falsepred label)))
- aft after label guard)
-
-let forwhile header body ((afvs,_,_,_) as aft) after
- quantified minus_quantified label recurse make_match guard =
- let process _ =
- (* the translation in this case is similar to that of an if with no else *)
- (* free variables *)
- let (efvs,bfvs) =
- match seq_fvs quantified [Ast.get_fvs header;Ast.get_fvs body;afvs] with
- [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs)
- | _ -> failwith "not possible" in
- let new_quantified = Common.union_set bfvs quantified in
- (* minus free variables *)
- let (mefvs,mbfvs) =
- match seq_fvs minus_quantified
- [Ast.get_mfvs header;Ast.get_mfvs body;[]] with
- [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs)
- | _ -> failwith "not possible" in
- let new_mquantified = Common.union_set mbfvs minus_quantified in
- (* loop header *)
- let header = quantify guard efvs (make_match header) in
- let lv = get_label_ctr() in
- let used = ref false in
- let body =
- make_seq guard
- [inlooppred label;
- recurse body Tail new_quantified new_mquantified
- (Some (lv,used)) (Some (lv,used)) None guard] in
- let after_pred = fallpred label in
- let or_cases after_branch = ctl_or body after_branch in
- let (header,wrapper) =
- if !used
- then
- let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in
- (ctl_and CTL.NONSTRICT(*???*) header label_pred,
- (function body -> quantify true [lv] body))
- else (header,function x -> x) in
- wrapper
- (end_control_structure bfvs header or_cases after_pred
- (Some(ctl_ex after_pred)) None aft after label guard) in
- match (Ast.unwrap body,aft) with
- (Ast.Atomic(re),(_,_,_,Ast.CONTEXT(_,Ast.NOTHING))) ->
- (match Ast.unwrap re with
- Ast.MetaStmt((_,_,Ast.CONTEXT(_,Ast.NOTHING),_),
- Type_cocci.Unitary,_,false) ->
- let (efvs) =
- match seq_fvs quantified [Ast.get_fvs header] with
- [(efvs,_)] -> efvs
- | _ -> failwith "not possible" in
- quantify guard efvs (make_match header)
- | _ -> process())
- | _ -> process()
-
-(* --------------------------------------------------------------------- *)
-(* statement metavariables *)
-
-(* issue: an S metavariable that is not an if branch/loop body
- should not match an if branch/loop body, so check that the labels
- of the nodes before the first node matched by the S are different
- from the label of the first node matched by the S *)
-let sequencibility body label_pred process_bef_aft = function
- Ast.Sequencible | Ast.SequencibleAfterDots [] ->
- body
- (function x ->
- (ctl_and CTL.NONSTRICT (ctl_not (ctl_back_ax label_pred)) x))
- | Ast.SequencibleAfterDots l ->
- (* S appears after some dots. l is the code that comes after the S.
- want to search for that first, because S can match anything, while
- the stuff after is probably more restricted *)
- let afts = List.map process_bef_aft l in
- let ors = foldl1 ctl_or afts in
- ctl_and CTL.NONSTRICT
- (ctl_ef (ctl_and CTL.NONSTRICT ors (ctl_back_ax label_pred)))
- (body
- (function x ->
- ctl_and CTL.NONSTRICT (ctl_not (ctl_back_ax label_pred)) x))
- | Ast.NotSequencible -> body (function x -> x)
-
-let svar_context_with_add_after stmt s label quantified d ast
- seqible after process_bef_aft guard fvinfo =
- let label_var = (*fresh_label_var*) string2var "_lab" in
- let label_pred =
- CTL.Pred (Lib_engine.Label(label_var),CTL.Control) in
- let prelabel_pred =
- CTL.Pred (Lib_engine.PrefixLabel(label_var),CTL.Control) in
- let matcher d = make_match None guard (make_meta_rule_elem d fvinfo) in
- let full_metamatch = matcher d in
- let first_metamatch =
- matcher
- (match d with
- Ast.CONTEXT(pos,Ast.BEFOREAFTER(bef,_)) ->
- Ast.CONTEXT(pos,Ast.BEFORE(bef))
- | Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING)
- | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in
- let middle_metamatch =
- matcher
- (match d with
- Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING)
- | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in
- let last_metamatch =
- matcher
- (match d with
- Ast.CONTEXT(pos,Ast.BEFOREAFTER(_,aft)) ->
- Ast.CONTEXT(pos,Ast.AFTER(aft))
- | Ast.CONTEXT(_,_) -> d
- | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in
-
- let rest_nodes =
- ctl_and CTL.NONSTRICT middle_metamatch prelabel_pred in
- let left_or = (* the whole statement is one node *)
- make_seq guard
- [full_metamatch; and_after guard (ctl_not prelabel_pred) after] in
- let right_or = (* the statement covers multiple nodes *)
- make_seq guard
- [first_metamatch;
- ctl_au CTL.NONSTRICT
- rest_nodes
- (make_seq guard
- [ctl_and CTL.NONSTRICT last_metamatch label_pred;
- and_after guard
- (ctl_not prelabel_pred) after])] in
- let body f =
- ctl_and CTL.NONSTRICT label_pred
- (f (ctl_and CTL.NONSTRICT
- (make_raw_match label false ast) (ctl_or left_or right_or))) in
- let stmt_fvs = Ast.get_fvs stmt in
- let fvs = get_unquantified quantified stmt_fvs in
- quantify guard (label_var::fvs)
- (sequencibility body label_pred process_bef_aft seqible)
-
-let svar_minus_or_no_add_after stmt s label quantified d ast
- seqible after process_bef_aft guard fvinfo =
- let label_var = (*fresh_label_var*) string2var "_lab" in
- let label_pred =
- CTL.Pred (Lib_engine.Label(label_var),CTL.Control) in
- let prelabel_pred =
- CTL.Pred (Lib_engine.PrefixLabel(label_var),CTL.Control) in
- let matcher d = make_match None guard (make_meta_rule_elem d fvinfo) in
- let pure_d =
- (* don't have to put anything before the beginning, so don't have to
- distinguish the first node. so don't have to bother about paths,
- just use the label. label ensures that found nodes match up with
- what they should because it is in the lhs of the andany. *)
- match d with
- Ast.MINUS(pos,[]) -> true
- | Ast.CONTEXT(pos,Ast.NOTHING) -> true
- | _ -> false in
- let ender =
- match (pure_d,after) with
- (true,Tail) | (true,End) | (true,VeryEnd) ->
- (* the label sharing makes it safe to use AndAny *)
- CTL.HackForStmt(CTL.FORWARD,CTL.NONSTRICT,
- ctl_and CTL.NONSTRICT label_pred
- (make_raw_match label false ast),
- ctl_and CTL.NONSTRICT (matcher d) prelabel_pred)
- | _ ->
- (* more safe but less efficient *)
- let first_metamatch = matcher d in
- let rest_metamatch =
- matcher
- (match d with
- Ast.MINUS(pos,_) -> Ast.MINUS(pos,[])
- | Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING)
- | Ast.PLUS -> failwith "not possible") in
- let rest_nodes = ctl_and CTL.NONSTRICT rest_metamatch prelabel_pred in
- let last_node = and_after guard (ctl_not prelabel_pred) after in
- (ctl_and CTL.NONSTRICT (make_raw_match label false ast)
- (make_seq guard
- [first_metamatch;
- ctl_au CTL.NONSTRICT rest_nodes last_node])) in
- let body f = ctl_and CTL.NONSTRICT label_pred (f ender) in
- let stmt_fvs = Ast.get_fvs stmt in
- let fvs = get_unquantified quantified stmt_fvs in
- quantify guard (label_var::fvs)
- (sequencibility body label_pred process_bef_aft seqible)
-
-(* --------------------------------------------------------------------- *)
-(* dots and nests *)
-
-let dots_au is_strict toend label s wrapcode x seq_after y quantifier =
- let matchgoto = gotopred None in
- let matchbreak =
- make_match None false
- (wrapcode
- (Ast.Break(Ast.make_mcode "break",Ast.make_mcode ";"))) in
- let matchcontinue =
- make_match None false
- (wrapcode
- (Ast.Continue(Ast.make_mcode "continue",Ast.make_mcode ";"))) in
- let stop_early =
- if quantifier = Exists
- then Common.Left(CTL.False)
- else if toend
- then Common.Left(CTL.Or(aftpred label,exitpred label))
- else if is_strict
- then Common.Left(aftpred label)
- else
- Common.Right
- (function v ->
- let lv = get_label_ctr() in
- let labelpred = CTL.Pred(Lib_engine.Label lv,CTL.Control) in
- let preflabelpred = label_pred_maker (Some (lv,ref true)) in
- ctl_or (aftpred label)
- (quantify false [lv]
- (ctl_and CTL.NONSTRICT
- (ctl_and CTL.NONSTRICT (truepred label) labelpred)
- (ctl_au CTL.NONSTRICT
- (ctl_and CTL.NONSTRICT (ctl_not v) preflabelpred)
- (ctl_and CTL.NONSTRICT preflabelpred
- (if !Flag_matcher.only_return_is_error_exit
- then
- (ctl_and CTL.NONSTRICT
- (retpred None) (ctl_not seq_after))
- else
- (ctl_or
- (ctl_and CTL.NONSTRICT
- (ctl_or (retpred None) matchcontinue)
- (ctl_not seq_after))
- (ctl_and CTL.NONSTRICT
- (ctl_or matchgoto matchbreak)
- (ctl_ag s (ctl_not seq_after)))))))))) in
- let op = if quantifier = !exists then ctl_au else ctl_anti_au in
- let v = get_let_ctr() in
- op s x
- (match stop_early with
- Common.Left x -> ctl_or y x
- | Common.Right stop_early ->
- CTL.Let(v,y,ctl_or (CTL.Ref v) (stop_early (CTL.Ref v))))
-
-let rec dots_and_nests plus nest whencodes bef aft dotcode after label
- process_bef_aft statement_list statement guard quantified wrapcode =
- let ctl_and_ns = ctl_and CTL.NONSTRICT in
- (* proces bef_aft *)
- let shortest l =
- List.fold_left ctl_or_fl CTL.False (List.map process_bef_aft l) in
- let bef_aft = (* to be negated *)
- try
- let _ =
- List.find
- (function Ast.WhenModifier(Ast.WhenAny) -> true | _ -> false)
- whencodes in
- CTL.False
- with Not_found -> shortest (Common.union_set bef aft) in
- let is_strict =
- List.exists
- (function Ast.WhenModifier(Ast.WhenStrict) -> true | _ -> false)
- whencodes in
- let check_quantifier quant other =
- if List.exists
- (function Ast.WhenModifier(x) -> x = quant | _ -> false)
- whencodes
- then
- if List.exists
- (function Ast.WhenModifier(x) -> x = other | _ -> false)
- whencodes
- then failwith "inconsistent annotation on dots"
- else true
- else false in
- let quantifier =
- if check_quantifier Ast.WhenExists Ast.WhenForall
- then Exists
- else
- if check_quantifier Ast.WhenForall Ast.WhenExists
- then Forall
- else !exists in
- (* the following is used when we find a goto, etc and consider accepting
- without finding the rest of the pattern *)
- let aft = shortest aft in
- (* process whencode *)
- let labelled = label_pred_maker label in
- let whencodes arg =
- let (poswhen,negwhen) =
- List.fold_left
- (function (poswhen,negwhen) ->
- function
- Ast.WhenNot whencodes ->
- (poswhen,ctl_or (statement_list whencodes) negwhen)
- | Ast.WhenAlways stm ->
- (ctl_and CTL.NONSTRICT (statement stm) poswhen,negwhen)
- | Ast.WhenModifier(_) -> (poswhen,negwhen)
- | Ast.WhenNotTrue(e) ->
- (poswhen,
- ctl_or (whencond_true e label guard quantified) negwhen)
- | Ast.WhenNotFalse(e) ->
- (poswhen,
- ctl_or (whencond_false e label guard quantified) negwhen))
- (CTL.True,bef_aft) (List.rev whencodes) in
- let poswhen = ctl_and_ns arg poswhen in
- let negwhen =
-(* if !exists
- then*)
- (* add in After, because it's not part of the program *)
- ctl_or (aftpred label) negwhen
- (*else negwhen*) in
- ctl_and_ns poswhen (ctl_not negwhen) in
- (* process dot code, if any *)
- let dotcode =
- match (dotcode,guard) with
- (None,_) | (_,true) -> CTL.True
- | (Some dotcode,_) -> dotcode in
- (* process nest code, if any *)
- (* whencode goes in the negated part of the nest; if no nest, just goes
- on the "true" in between code *)
- let plus_var = if plus then get_label_ctr() else string2var "" in
- let plus_var2 = if plus then get_label_ctr() else string2var "" in
- let ornest =
- match (nest,guard && not plus) with
- (None,_) | (_,true) -> whencodes CTL.True
- | (Some nest,false) ->
- let v = get_let_ctr() in
- let is_plus x =
- if plus
- then
- (* the idea is that BindGood is sort of a witness; a witness to
- having found the subterm in at least one place. If there is
- not a witness, then there is a risk that it will get thrown
- away, if it is merged with a node that has an empty
- environment. See tests/nestplus. But this all seems
- rather suspicious *)
- CTL.And(CTL.NONSTRICT,x,
- CTL.Exists(true,plus_var2,
- CTL.Pred(Lib_engine.BindGood(plus_var),
- CTL.Modif plus_var2)))
- else x in
- CTL.Let(v,nest,
- CTL.Or(is_plus (CTL.Ref v),
- whencodes (CTL.Not(ctl_uncheck (CTL.Ref v))))) in
- let plus_modifier x =
- if plus
- then
- CTL.Exists
- (false,plus_var,
- (CTL.And
- (CTL.NONSTRICT,x,
- CTL.Not(CTL.Pred(Lib_engine.BindBad(plus_var),CTL.Control)))))
- else x in
-
- let ender =
- match after with
- After f -> f
- | Guard f -> ctl_uncheck f
- | VeryEnd ->
- let exit = endpred label in
- let errorexit = exitpred label in
- ctl_or exit errorexit
- (* not at all sure what the next two mean... *)
- | End -> CTL.True
- | Tail ->
- (match label with
- Some (lv,used) -> used := true;
- ctl_or (CTL.Pred(Lib_engine.Label lv,CTL.Control))
- (ctl_back_ex (ctl_or (retpred label) (gotopred label)))
- | None -> endpred label)
- (* was the following, but not clear why sgrep should allow
- incomplete patterns
- let exit = endpred label in
- let errorexit = exitpred label in
- if !exists
- then ctl_or exit errorexit (* end anywhere *)
- else exit (* end at the real end of the function *) *) in
- plus_modifier
- (dots_au is_strict ((after = Tail) or (after = VeryEnd))
- label (guard_to_strict guard) wrapcode
- (ctl_and_ns dotcode (ctl_and_ns ornest labelled))
- aft ender quantifier)
-
-and get_whencond_exps e =
- match Ast.unwrap e with
- Ast.Exp e -> [e]
- | Ast.DisjRuleElem(res) ->
- List.fold_left Common.union_set [] (List.map get_whencond_exps res)
- | _ -> failwith "not possible"
-
-and make_whencond_headers e e1 label guard quantified =
- let fvs = Ast.get_fvs e in
- let header_pred h =
- quantify guard (get_unquantified quantified fvs)
- (make_match label guard h) in
- let if_header e1 =
- header_pred
- (Ast.rewrap e
- (Ast.IfHeader
- (Ast.make_mcode "if",
- Ast.make_mcode "(",e1,Ast.make_mcode ")"))) in
- let while_header e1 =
- header_pred
- (Ast.rewrap e
- (Ast.WhileHeader
- (Ast.make_mcode "while",
- Ast.make_mcode "(",e1,Ast.make_mcode ")"))) in
- let for_header e1 =
- header_pred
- (Ast.rewrap e
- (Ast.ForHeader
- (Ast.make_mcode "for",Ast.make_mcode "(",None,Ast.make_mcode ";",
- Some e1,Ast.make_mcode ";",None,Ast.make_mcode ")"))) in
- let if_headers =
- List.fold_left ctl_or CTL.False (List.map if_header e1) in
- let while_headers =
- List.fold_left ctl_or CTL.False (List.map while_header e1) in
- let for_headers =
- List.fold_left ctl_or CTL.False (List.map for_header e1) in
- (if_headers, while_headers, for_headers)
-
-and whencond_true e label guard quantified =
- let e1 = get_whencond_exps e in
- let (if_headers, while_headers, for_headers) =
- make_whencond_headers e e1 label guard quantified in
- ctl_or
- (ctl_and CTL.NONSTRICT (truepred label) (ctl_back_ex if_headers))
- (ctl_and CTL.NONSTRICT
- (inlooppred label) (ctl_back_ex (ctl_or while_headers for_headers)))
-
-and whencond_false e label guard quantified =
- let e1 = get_whencond_exps e in
- let (if_headers, while_headers, for_headers) =
- make_whencond_headers e e1 label guard quantified in
- ctl_or (ctl_and CTL.NONSTRICT (falsepred label) (ctl_back_ex if_headers))
- (ctl_and CTL.NONSTRICT (fallpred label)
- (ctl_or (ctl_back_ex if_headers)
- (ctl_or (ctl_back_ex while_headers) (ctl_back_ex for_headers))))
-
-(* --------------------------------------------------------------------- *)
-(* the main translation loop *)
-
-let rec statement_list stmt_list after quantified minus_quantified
- label llabel slabel dots_before guard =
- let isdots x =
- (* include Disj to be on the safe side *)
- match Ast.unwrap x with
- Ast.Dots _ | Ast.Nest _ | Ast.Disj _ -> true | _ -> false in
- let compute_label l e db = if db or isdots e then l else None in
- match Ast.unwrap stmt_list with
- Ast.DOTS(x) ->
- let rec loop quantified minus_quantified dots_before label llabel slabel
- = function
- ([],_,_) -> (match after with After f -> f | _ -> CTL.True)
- | ([e],_,_) ->
- statement e after quantified minus_quantified
- (compute_label label e dots_before)
- llabel slabel guard
- | (e::sl,fv::fvs,mfv::mfvs) ->
- let shared = intersectll fv fvs in
- let unqshared = get_unquantified quantified shared in
- let new_quantified = Common.union_set unqshared quantified in
- let minus_shared = intersectll mfv mfvs in
- let munqshared =
- get_unquantified minus_quantified minus_shared in
- let new_mquantified =
- Common.union_set munqshared minus_quantified in
- quantify guard unqshared
- (statement e
- (After
- (let (label1,llabel1,slabel1) =
- match Ast.unwrap e with
- Ast.Atomic(re) ->
- (match Ast.unwrap re with
- Ast.Goto _ -> (None,None,None)
- | _ -> (label,llabel,slabel))
- | _ -> (label,llabel,slabel) in
- loop new_quantified new_mquantified (isdots e)
- label1 llabel1 slabel1
- (sl,fvs,mfvs)))
- new_quantified new_mquantified
- (compute_label label e dots_before) llabel slabel guard)
- | _ -> failwith "not possible" in
- loop quantified minus_quantified dots_before
- label llabel slabel
- (x,List.map Ast.get_fvs x,List.map Ast.get_mfvs x)
- | Ast.CIRCLES(x) -> failwith "not supported"
- | Ast.STARS(x) -> failwith "not supported"
-
-(* llabel is the label of the enclosing loop and slabel is the label of the
- enclosing switch *)
-and statement stmt after quantified minus_quantified
- label llabel slabel guard =
- let ctl_au = ctl_au CTL.NONSTRICT in
- let ctl_ax = ctl_ax CTL.NONSTRICT in
- let ctl_and = ctl_and CTL.NONSTRICT in
- let make_seq = make_seq guard in
- let make_seq_after = make_seq_after guard in
- let real_make_match = make_match in
- let make_match = header_match label guard in
-
- let dots_done = ref false in (* hack for dots cases we can easily handle *)
-
- let term =
- match Ast.unwrap stmt with
- Ast.Atomic(ast) ->
- (match Ast.unwrap ast with
- (* the following optimisation is not a good idea, because when S
- is alone, we would like it not to match a declaration.
- this makes more matching for things like when (...) S, but perhaps
- that matching is not so costly anyway *)
- (*Ast.MetaStmt(_,Type_cocci.Unitary,_,false) when guard -> CTL.True*)
- | Ast.MetaStmt((s,_,(Ast.CONTEXT(_,Ast.BEFOREAFTER(_,_)) as d),_),
- keep,seqible,_)
- | Ast.MetaStmt((s,_,(Ast.CONTEXT(_,Ast.AFTER(_)) as d),_),
- keep,seqible,_)->
- svar_context_with_add_after stmt s label quantified d ast seqible
- after
- (process_bef_aft quantified minus_quantified
- label llabel slabel true)
- guard
- (Ast.get_fvs stmt, Ast.get_fresh stmt, Ast.get_inherited stmt)
-
- | Ast.MetaStmt((s,_,d,_),keep,seqible,_) ->
- svar_minus_or_no_add_after stmt s label quantified d ast seqible
- after
- (process_bef_aft quantified minus_quantified
- label llabel slabel true)
- guard
- (Ast.get_fvs stmt, Ast.get_fresh stmt, Ast.get_inherited stmt)
-
- | _ ->
- let term =
- match Ast.unwrap ast with
- Ast.DisjRuleElem(res) ->
- do_re_matches label guard res quantified minus_quantified
- | Ast.Exp(_) | Ast.Ty(_) ->
- let stmt_fvs = Ast.get_fvs stmt in
- let fvs = get_unquantified quantified stmt_fvs in
- CTL.InnerAnd(quantify guard fvs (make_match ast))
- | _ ->
- let stmt_fvs = Ast.get_fvs stmt in
- let fvs = get_unquantified quantified stmt_fvs in
- quantify guard fvs (make_match ast) in
- match Ast.unwrap ast with
- Ast.Break(brk,semi) ->
- (match (llabel,slabel) with
- (_,Some(lv,used)) -> (* use switch label if there is one *)
- ctl_and term (bclabel_pred_maker slabel)
- | _ -> ctl_and term (bclabel_pred_maker llabel))
- | Ast.Continue(brk,semi) -> ctl_and term (bclabel_pred_maker llabel)
- | Ast.Return((_,info,retmc,pos),(_,_,semmc,_)) ->
- (* discard pattern that comes after return *)
- let normal_res = make_seq_after term after in
- (* the following code tries to propagate the modifications on
- return; to a close brace, in the case where the final return
- is absent *)
- let new_mc =
- match (retmc,semmc) with
- (Ast.MINUS(_,l1),Ast.MINUS(_,l2)) when !Flag.sgrep_mode2 ->
- (* in sgrep mode, we can propagate the - *)
- Some (Ast.MINUS(Ast.NoPos,l1@l2))
- | (Ast.MINUS(_,l1),Ast.MINUS(_,l2))
- | (Ast.CONTEXT(_,Ast.BEFORE(l1)),
- Ast.CONTEXT(_,Ast.AFTER(l2))) ->
- Some (Ast.CONTEXT(Ast.NoPos,Ast.BEFORE(l1@l2)))
- | (Ast.CONTEXT(_,Ast.BEFORE(_)),Ast.CONTEXT(_,Ast.NOTHING))
- | (Ast.CONTEXT(_,Ast.NOTHING),Ast.CONTEXT(_,Ast.NOTHING)) ->
- Some retmc
- | (Ast.CONTEXT(_,Ast.NOTHING),Ast.CONTEXT(_,Ast.AFTER(l))) ->
- Some (Ast.CONTEXT(Ast.NoPos,Ast.BEFORE(l)))
- | _ -> None in
- let ret = Ast.make_mcode "return" in
- let edots =
- Ast.rewrap ast (Ast.Edots(Ast.make_mcode "...",None)) in
- let semi = Ast.make_mcode ";" in
- let simple_return =
- make_match(Ast.rewrap ast (Ast.Return(ret,semi))) in
- let return_expr =
- make_match(Ast.rewrap ast (Ast.ReturnExpr(ret,edots,semi))) in
- (match new_mc with
- Some new_mc ->
- let exit = endpred None in
- let mod_rbrace =
- Ast.rewrap ast (Ast.SeqEnd (("}",info,new_mc,pos))) in
- let stripped_rbrace =
- Ast.rewrap ast (Ast.SeqEnd(Ast.make_mcode "}")) in
- ctl_or normal_res
- (ctl_and (make_match mod_rbrace)
- (ctl_and
- (ctl_back_ax
- (ctl_not
- (ctl_uncheck
- (ctl_or simple_return return_expr))))
- (ctl_au
- (make_match stripped_rbrace)
- (* error exit not possible; it is in the middle
- of code, so a return is needed *)
- exit)))
- | _ ->
- (* some change in the middle of the return, so have to
- find an actual return *)
- normal_res)
- | _ ->
- (* should try to deal with the dots_bef_aft problem elsewhere,
- but don't have the courage... *)
- let term =
- if guard
- then term
- else
- do_between_dots stmt term End
- quantified minus_quantified label llabel slabel guard in
- dots_done := true;
- make_seq_after term after)
- | Ast.Seq(lbrace,decls,body,rbrace) ->
- let (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) =
- match
- seq_fvs quantified
- [Ast.get_fvs lbrace;Ast.get_fvs decls;
- Ast.get_fvs body;Ast.get_fvs rbrace]
- with
- [(lbfvs,b1fvs);(_,b2fvs);(_,b3fvs);(rbfvs,_)] ->
- (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs)
- | _ -> failwith "not possible" in
- let (mlbfvs,mb1fvs,mb2fvs,mb3fvs,mrbfvs) =
- match
- seq_fvs minus_quantified
- [Ast.get_mfvs lbrace;Ast.get_mfvs decls;
- Ast.get_mfvs body;Ast.get_mfvs rbrace]
- with
- [(lbfvs,b1fvs);(_,b2fvs);(_,b3fvs);(rbfvs,_)] ->
- (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs)
- | _ -> failwith "not possible" in
- let pv = count_nested_braces stmt in
- let lv = get_label_ctr() in
- let paren_pred = CTL.Pred(Lib_engine.Paren pv,CTL.Control) in
- let label_pred = CTL.Pred(Lib_engine.Label lv,CTL.Control) in
- let start_brace =
- ctl_and
- (quantify guard lbfvs (make_match lbrace))
- (ctl_and paren_pred label_pred) in
- let empty_rbrace =
- match Ast.unwrap rbrace with
- Ast.SeqEnd((data,info,_,pos)) ->
- Ast.rewrap rbrace(Ast.SeqEnd(Ast.make_mcode data))
- | _ -> failwith "unexpected close brace" in
- let end_brace =
- (* label is not needed; paren_pred is enough *)
- quantify guard rbfvs
- (ctl_au (make_match empty_rbrace)
- (ctl_and
- (real_make_match None guard rbrace)
- paren_pred)) in
- let new_quantified2 =
- Common.union_set b1fvs (Common.union_set b2fvs quantified) in
- let new_quantified3 = Common.union_set b3fvs new_quantified2 in
- let new_mquantified2 =
- Common.union_set mb1fvs (Common.union_set mb2fvs minus_quantified) in
- let new_mquantified3 = Common.union_set mb3fvs new_mquantified2 in
- let pattern_as_given =
- let new_quantified2 = Common.union_set [pv] new_quantified2 in
- let new_quantified3 = Common.union_set [pv] new_quantified3 in
- quantify true [pv;lv]
- (quantify guard b1fvs
- (make_seq
- [start_brace;
- quantify guard b2fvs
- (statement_list decls
- (After
- (quantify guard b3fvs
- (statement_list body
- (After (make_seq_after end_brace after))
- new_quantified3 new_mquantified3
- (Some (lv,ref true)) (* label mostly useful *)
- llabel slabel true guard)))
- new_quantified2 new_mquantified2
- (Some (lv,ref true)) llabel slabel false guard)])) in
- if ends_in_return body
- then
- (* matching error handling code *)
- (* Cases:
- 1. The pattern as given
- 2. A goto, and then some close braces, and then the pattern as
- given, but without the braces (only possible if there are no
- decls, and open and close braces are unmodified)
- 3. Part of the pattern as given, then a goto, and then the rest
- of the pattern. For this case, we just check that all paths have
- a goto within the current braces. checking for a goto at every
- point in the pattern seems expensive and not worthwhile. *)
- let pattern2 =
- let body = preprocess_dots body in (* redo, to drop braces *)
- make_seq
- [gotopred label;
- ctl_au
- (make_match empty_rbrace)
- (ctl_ax (* skip the destination label *)
- (quantify guard b3fvs
- (statement_list body End
- new_quantified3 new_mquantified3 None llabel slabel
- true guard)))] in
- let pattern3 =
- let new_quantified2 = Common.union_set [pv] new_quantified2 in
- let new_quantified3 = Common.union_set [pv] new_quantified3 in
- quantify true [pv;lv]
- (quantify guard b1fvs
- (make_seq
- [start_brace;
- ctl_and
- (CTL.AU (* want AF even for sgrep *)
- (CTL.FORWARD,CTL.STRICT,
- CTL.Pred(Lib_engine.PrefixLabel(lv),CTL.Control),
- ctl_and (* brace must be eventually after goto *)
- (gotopred (Some (lv,ref true)))
- (* want AF even for sgrep *)
- (CTL.AF(CTL.FORWARD,CTL.STRICT,end_brace))))
- (quantify guard b2fvs
- (statement_list decls
- (After
- (quantify guard b3fvs
- (statement_list body Tail
- (*After
- (make_seq_after
- nopv_end_brace after)*)
- new_quantified3 new_mquantified3
- None llabel slabel true guard)))
- new_quantified2 new_mquantified2
- (Some (lv,ref true))
- llabel slabel false guard))])) in
- ctl_or pattern_as_given
- (match Ast.unwrap decls with
- Ast.DOTS([]) -> ctl_or pattern2 pattern3
- | Ast.DOTS(l) -> pattern3
- | _ -> failwith "circles and stars not supported")
- else pattern_as_given
- | Ast.IfThen(ifheader,branch,aft) ->
- ifthen ifheader branch aft after quantified minus_quantified
- label llabel slabel statement make_match guard
-
- | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) ->
- ifthenelse ifheader branch1 els branch2 aft after quantified
- minus_quantified label llabel slabel statement make_match guard
-
- | Ast.While(header,body,aft) | Ast.For(header,body,aft)
- | Ast.Iterator(header,body,aft) ->
- forwhile header body aft after quantified minus_quantified
- label statement make_match guard
-
- | Ast.Disj(stmt_dots_list) -> (* list shouldn't be empty *)
- ctl_and
- (label_pred_maker label)
- (List.fold_left ctl_seqor CTL.False
- (List.map
- (function sl ->
- statement_list sl after quantified minus_quantified label
- llabel slabel true guard)
- stmt_dots_list))
-
- | Ast.Nest(stmt_dots,whencode,multi,bef,aft) ->
- (* label in recursive call is None because label check is already
- wrapped around the corresponding code *)
-
- let bfvs =
- match seq_fvs quantified [Ast.get_wcfvs whencode;Ast.get_fvs stmt_dots]
- with
- [(wcfvs,bothfvs);(bdfvs,_)] -> bothfvs
- | _ -> failwith "not possible" in
-
- (* no minus version because when code doesn't contain any minus code *)
- let new_quantified = Common.union_set bfvs quantified in
-
- quantify guard bfvs
- (let dots_pattern =
- statement_list stmt_dots (a2n after) new_quantified minus_quantified
- None llabel slabel true guard in
- dots_and_nests multi
- (Some dots_pattern) whencode bef aft None after label
- (process_bef_aft new_quantified minus_quantified
- None llabel slabel true)
- (function x ->
- statement_list x Tail new_quantified minus_quantified None
- llabel slabel true true)
- (function x ->
- statement x Tail new_quantified minus_quantified None
- llabel slabel true)
- guard quantified
- (function x -> Ast.set_fvs [] (Ast.rewrap stmt x)))
-
- | Ast.Dots((_,i,d,_),whencodes,bef,aft) ->
- let dot_code =
- match d with
- Ast.MINUS(_,_) ->
- (* no need for the fresh metavar, but ... is a bit wierd as a
- variable name *)
- Some(make_match (make_meta_rule_elem d ([],[],[])))
- | _ -> None in
- dots_and_nests false None whencodes bef aft dot_code after label
- (process_bef_aft quantified minus_quantified None llabel slabel true)
- (function x ->
- statement_list x Tail quantified minus_quantified
- None llabel slabel true true)
- (function x ->
- statement x Tail quantified minus_quantified None llabel slabel true)
- guard quantified
- (function x -> Ast.set_fvs [] (Ast.rewrap stmt x))
-
- | Ast.Switch(header,lb,cases,rb) ->
- let rec intersect_all = function
- [] -> []
- | [x] -> x
- | x::xs -> intersect x (intersect_all xs) in
- let rec union_all l = List.fold_left union [] l in
- (* start normal variables *)
- let header_fvs = Ast.get_fvs header in
- let lb_fvs = Ast.get_fvs lb in
- let case_fvs = List.map Ast.get_fvs cases in
- let rb_fvs = Ast.get_fvs rb in
- let (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs,
- all_casefvs,all_b3fvs,all_rbfvs) =
- List.fold_left
- (function (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs,
- all_casefvs,all_b3fvs,all_rbfvs) ->
- function case_fvs ->
- match seq_fvs quantified [header_fvs;lb_fvs;case_fvs;rb_fvs] with
- [(efvs,b1fvs);(lbfvs,b2fvs);(casefvs,b3fvs);(rbfvs,_)] ->
- (efvs::all_efvs,b1fvs::all_b1fvs,lbfvs::all_lbfvs,
- b2fvs::all_b2fvs,casefvs::all_casefvs,b3fvs::all_b3fvs,
- rbfvs::all_rbfvs)
- | _ -> failwith "not possible")
- ([],[],[],[],[],[],[]) case_fvs in
- let (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs,
- all_casefvs,all_b3fvs,all_rbfvs) =
- (List.rev all_efvs,List.rev all_b1fvs,List.rev all_lbfvs,
- List.rev all_b2fvs,List.rev all_casefvs,List.rev all_b3fvs,
- List.rev all_rbfvs) in
- let exponlyfvs = intersect_all all_efvs in
- let lbonlyfvs = intersect_all all_lbfvs in
-(* don't do anything with right brace. Hope there is no + code on it *)
-(* let rbonlyfvs = intersect_all all_rbfvs in*)
- let b1fvs = union_all all_b1fvs in
- let new1_quantified = union b1fvs quantified in
- let b2fvs = union (union_all all_b1fvs) (intersect_all all_casefvs) in
- let new2_quantified = union b2fvs new1_quantified in
-(* let b3fvs = union_all all_b3fvs in*)
- (* ------------------- start minus free variables *)
- let header_mfvs = Ast.get_mfvs header in
- let lb_mfvs = Ast.get_mfvs lb in
- let case_mfvs = List.map Ast.get_mfvs cases in
- let rb_mfvs = Ast.get_mfvs rb in
- let (all_mefvs,all_mb1fvs,all_mlbfvs,all_mb2fvs,
- all_mcasefvs,all_mb3fvs,all_mrbfvs) =
- List.fold_left
- (function (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs,
- all_casefvs,all_b3fvs,all_rbfvs) ->
- function case_mfvs ->
- match
- seq_fvs quantified
- [header_mfvs;lb_mfvs;case_mfvs;rb_mfvs] with
- [(efvs,b1fvs);(lbfvs,b2fvs);(casefvs,b3fvs);(rbfvs,_)] ->
- (efvs::all_efvs,b1fvs::all_b1fvs,lbfvs::all_lbfvs,
- b2fvs::all_b2fvs,casefvs::all_casefvs,b3fvs::all_b3fvs,
- rbfvs::all_rbfvs)
- | _ -> failwith "not possible")
- ([],[],[],[],[],[],[]) case_mfvs in
- let (all_mefvs,all_mb1fvs,all_mlbfvs,all_mb2fvs,
- all_mcasefvs,all_mb3fvs,all_mrbfvs) =
- (List.rev all_mefvs,List.rev all_mb1fvs,List.rev all_mlbfvs,
- List.rev all_mb2fvs,List.rev all_mcasefvs,List.rev all_mb3fvs,
- List.rev all_mrbfvs) in
-(* don't do anything with right brace. Hope there is no + code on it *)
-(* let rbonlyfvs = intersect_all all_rbfvs in*)
- let mb1fvs = union_all all_mb1fvs in
- let new1_mquantified = union mb1fvs quantified in
- let mb2fvs = union (union_all all_mb1fvs) (intersect_all all_mcasefvs) in
- let new2_mquantified = union mb2fvs new1_mquantified in
-(* let b3fvs = union_all all_b3fvs in*)
- (* ------------------- end collection of free variables *)
- let switch_header = quantify guard exponlyfvs (make_match header) in
- let lb = quantify guard lbonlyfvs (make_match lb) in
-(* let rb = quantify guard rbonlyfvs (make_match rb) in*)
- let case_headers =
- List.map
- (function case_line ->
- match Ast.unwrap case_line with
- Ast.CaseLine(header,body) ->
- let e1fvs =
- match seq_fvs new2_quantified [Ast.get_fvs header] with
- [(e1fvs,_)] -> e1fvs
- | _ -> failwith "not possible" in
- quantify guard e1fvs (real_make_match label true header)
- | Ast.OptCase(case_line) -> failwith "not supported")
- cases in
- let no_header =
- ctl_not (List.fold_left ctl_or_fl CTL.False case_headers) in
- let lv = get_label_ctr() in
- let used = ref false in
- let case_code =
- List.map
- (function case_line ->
- match Ast.unwrap case_line with
- Ast.CaseLine(header,body) ->
- let (e1fvs,b1fvs,s1fvs) =
- let fvs = [Ast.get_fvs header;Ast.get_fvs body] in
- match seq_fvs new2_quantified fvs with
- [(e1fvs,b1fvs);(s1fvs,_)] -> (e1fvs,b1fvs,s1fvs)
- | _ -> failwith "not possible" in
- let (me1fvs,mb1fvs,ms1fvs) =
- let fvs = [Ast.get_mfvs header;Ast.get_mfvs body] in
- match seq_fvs new2_mquantified fvs with
- [(e1fvs,b1fvs);(s1fvs,_)] -> (e1fvs,b1fvs,s1fvs)
- | _ -> failwith "not possible" in
- let case_header =
- quantify guard e1fvs (make_match header) in
- let new3_quantified = union b1fvs new2_quantified in
- let new3_mquantified = union mb1fvs new2_mquantified in
- let body =
- statement_list body Tail
- new3_quantified new3_mquantified label llabel
- (Some (lv,used)) true(*?*) guard in
- quantify guard b1fvs (make_seq [case_header; body])
- | Ast.OptCase(case_line) -> failwith "not supported")
- cases in
- let default_required =
- if List.exists
- (function case ->
- match Ast.unwrap case with
- Ast.CaseLine(header,_) ->
- (match Ast.unwrap header with
- Ast.Default(_,_) -> true
- | _ -> false)
- | _ -> false)
- cases
- then function x -> x
- else function x -> ctl_or (fallpred label) x in
- let after_pred = aftpred label in
- let body after_branch =
- ctl_or
- (default_required
- (quantify guard b2fvs
- (make_seq
- [ctl_and lb
- (List.fold_left ctl_and CTL.True
- (List.map ctl_ex case_headers));
- List.fold_left ctl_or_fl no_header case_code])))
- after_branch in
- let aft =
- (rb_fvs,Ast.get_fresh rb,Ast.get_inherited rb,
- match Ast.unwrap rb with
- Ast.SeqEnd(rb) -> Ast.get_mcodekind rb
- | _ -> failwith "not possible") in
- let (switch_header,wrapper) =
- if !used
- then
- let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in
- (ctl_and switch_header label_pred,
- (function body -> quantify true [lv] body))
- else (switch_header,function x -> x) in
- wrapper
- (end_control_structure b1fvs switch_header body
- after_pred (Some(ctl_ex after_pred)) None aft after label guard)
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- let (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) =
- match
- seq_fvs quantified
- [Ast.get_fvs header;Ast.get_fvs lbrace;Ast.get_fvs decls;
- Ast.get_fvs body;Ast.get_fvs rbrace]
- with
- [(hfvs,b1fvs);(lbfvs,b2fvs);(_,b3fvs);(_,b4fvs);(rbfvs,_)] ->
- (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs)
- | _ -> failwith "not possible" in
- let (mhfvs,mb1fvs,mlbfvs,mb2fvs,mb3fvs,mb4fvs,mrbfvs) =
- match
- seq_fvs quantified
- [Ast.get_mfvs header;Ast.get_mfvs lbrace;Ast.get_mfvs decls;
- Ast.get_mfvs body;Ast.get_mfvs rbrace]
- with
- [(hfvs,b1fvs);(lbfvs,b2fvs);(_,b3fvs);(_,b4fvs);(rbfvs,_)] ->
- (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs)
- | _ -> failwith "not possible" in
- let function_header = quantify guard hfvs (make_match header) in
- let start_brace = quantify guard lbfvs (make_match lbrace) in
- let stripped_rbrace =
- match Ast.unwrap rbrace with
- Ast.SeqEnd((data,info,_,_)) ->
- Ast.rewrap rbrace(Ast.SeqEnd (Ast.make_mcode data))
- | _ -> failwith "unexpected close brace" in
- let end_brace =
- let exit = CTL.Pred (Lib_engine.Exit,CTL.Control) in
- let errorexit = CTL.Pred (Lib_engine.ErrorExit,CTL.Control) in
- let fake_brace = CTL.Pred (Lib_engine.FakeBrace,CTL.Control) in
- ctl_and
- (quantify guard rbfvs (make_match rbrace))
- (ctl_and
- (* the following finds the beginning of the fake braces,
- if there are any, not completely sure how this works.
- sse the examples sw and return *)
- (ctl_back_ex (ctl_not fake_brace))
- (ctl_au (make_match stripped_rbrace) (ctl_or exit errorexit))) in
- let new_quantified3 =
- Common.union_set b1fvs
- (Common.union_set b2fvs (Common.union_set b3fvs quantified)) in
- let new_quantified4 = Common.union_set b4fvs new_quantified3 in
- let new_mquantified3 =
- Common.union_set mb1fvs
- (Common.union_set mb2fvs
- (Common.union_set mb3fvs minus_quantified)) in
- let new_mquantified4 = Common.union_set mb4fvs new_mquantified3 in
- let fn_nest =
- match (Ast.undots decls,Ast.undots body,
- contains_modif rbrace or contains_pos rbrace) with
- ([],[body],false) ->
- (match Ast.unwrap body with
- Ast.Nest(stmt_dots,[],multi,_,_) ->
- if multi
- then None (* not sure how to optimize this case *)
- else Some (Common.Left stmt_dots)
- | Ast.Dots(_,whencode,_,_) when
- (List.for_all
- (* flow sensitive, so not optimizable *)
- (function Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) ->
- false
- | _ -> true) whencode) ->
- Some (Common.Right whencode)
- | _ -> None)
- | _ -> None in
- let body_code =
- match fn_nest with
- Some (Common.Left stmt_dots) ->
- (* special case for function header + body - header is unambiguous
- and unique, so we can just look for the nested body anywhere
- else in the CFG *)
- CTL.AndAny
- (CTL.FORWARD,guard_to_strict guard,start_brace,
- statement_list stmt_dots
- (* discards match on right brace, but don't need it *)
- (Guard (make_seq_after end_brace after))
- new_quantified4 new_mquantified4
- None llabel slabel true guard)
- | Some (Common.Right whencode) ->
- (* try to be more efficient for the case where the body is just
- ... Perhaps this is too much of a special case, but useful
- for dropping a parameter and checking that it is never used. *)
- make_seq
- [start_brace;
- match whencode with
- [] -> CTL.True
- | _ ->
- let leftarg =
- ctl_and
- (ctl_not
- (List.fold_left
- (function prev ->
- function
- Ast.WhenAlways(s) -> prev
- | Ast.WhenNot(sl) ->
- let x =
- statement_list sl Tail
- new_quantified4 new_mquantified4
- label llabel slabel true true in
- ctl_or prev x
- | Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) ->
- failwith "unexpected"
- | Ast.WhenModifier(Ast.WhenAny) -> CTL.False
- | Ast.WhenModifier(_) -> prev)
- CTL.False whencode))
- (List.fold_left
- (function prev ->
- function
- Ast.WhenAlways(s) ->
- let x =
- statement s Tail
- new_quantified4 new_mquantified4
- label llabel slabel true in
- ctl_and prev x
- | Ast.WhenNot(sl) -> prev
- | Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) ->
- failwith "unexpected"
- | Ast.WhenModifier(Ast.WhenAny) -> CTL.True
- | Ast.WhenModifier(_) -> prev)
- CTL.True whencode) in
- ctl_au leftarg (make_match stripped_rbrace)]
- | None ->
- make_seq
- [start_brace;
- quantify guard b3fvs
- (statement_list decls
- (After
- (quantify guard b4fvs
- (statement_list body
- (After (make_seq_after end_brace after))
- new_quantified4 new_mquantified4
- None llabel slabel true guard)))
- new_quantified3 new_mquantified3 None llabel slabel
- false guard)] in
- quantify guard b1fvs
- (make_seq [function_header; quantify guard b2fvs body_code])
- | Ast.Define(header,body) ->
- let (hfvs,bfvs,bodyfvs) =
- match seq_fvs quantified [Ast.get_fvs header;Ast.get_fvs body]
- with
- [(hfvs,b1fvs);(bodyfvs,_)] -> (hfvs,b1fvs,bodyfvs)
- | _ -> failwith "not possible" in
- let (mhfvs,mbfvs,mbodyfvs) =
- match seq_fvs minus_quantified [Ast.get_mfvs header;Ast.get_mfvs body]
- with
- [(hfvs,b1fvs);(bodyfvs,_)] -> (hfvs,b1fvs,bodyfvs)
- | _ -> failwith "not possible" in
- let define_header = quantify guard hfvs (make_match header) in
- let body_code =
- statement_list body after
- (Common.union_set bfvs quantified)
- (Common.union_set mbfvs minus_quantified)
- None llabel slabel true guard in
- quantify guard bfvs (make_seq [define_header; body_code])
- | Ast.OptStm(stm) ->
- failwith "OptStm should have been compiled away\n"
- | Ast.UniqueStm(stm) -> failwith "arities not yet supported"
- | _ -> failwith "not supported" in
- if guard or !dots_done
- then term
- else
- do_between_dots stmt term after quantified minus_quantified
- label llabel slabel guard
-
-(* term is the translation of stmt *)
-and do_between_dots stmt term after quantified minus_quantified
- label llabel slabel guard =
- match Ast.get_dots_bef_aft stmt with
- Ast.AddingBetweenDots (brace_term,n)
- | Ast.DroppingBetweenDots (brace_term,n) ->
- let match_brace =
- statement brace_term after quantified minus_quantified
- label llabel slabel guard in
- let v = Printf.sprintf "_r_%d" n in
- let case1 = ctl_and CTL.NONSTRICT (CTL.Ref v) match_brace in
- let case2 = ctl_and CTL.NONSTRICT (ctl_not (CTL.Ref v)) term in
- CTL.Let
- (v,ctl_or
- (ctl_back_ex (ctl_or (truepred label) (inlooppred label)))
- (ctl_back_ex (ctl_back_ex (falsepred label))),
- ctl_or case1 case2)
- | Ast.NoDots -> term
-
-(* un_process_bef_aft is because we don't want to do transformation in this
- code, and thus don't case about braces before or after it *)
-and process_bef_aft quantified minus_quantified label llabel slabel guard =
- function
- Ast.WParen (re,n) ->
- let paren_pred = CTL.Pred (Lib_engine.Paren n,CTL.Control) in
- let s = guard_to_strict guard in
- quantify true (get_unquantified quantified [n])
- (ctl_and s (make_raw_match None guard re) paren_pred)
- | Ast.Other s ->
- statement s Tail quantified minus_quantified label llabel slabel guard
- | Ast.Other_dots d ->
- statement_list d Tail quantified minus_quantified
- label llabel slabel true guard
-
-(* --------------------------------------------------------------------- *)
-(* cleanup: convert AX to EX for pdots.
-Concretely: AX(A[...] & E[...]) becomes AX(A[...]) & EX(E[...])
-This is what we wanted in the first place, but it wasn't possible to make
-because the AX and its argument are not created in the same place.
-Rather clunky... *)
-(* also cleanup XX, which is a marker for the case where the programmer
-specifies to change the quantifier on .... Assumed to only occur after one AX
-or EX, or at top level. *)
-
-let rec cleanup c =
- let c = match c with CTL.XX(c) -> c | _ -> c in
- match c with
- CTL.False -> CTL.False
- | CTL.True -> CTL.True
- | CTL.Pred(p) -> CTL.Pred(p)
- | CTL.Not(phi) -> CTL.Not(cleanup phi)
- | CTL.Exists(keep,v,phi) -> CTL.Exists(keep,v,cleanup phi)
- | CTL.AndAny(dir,s,phi1,phi2) ->
- CTL.AndAny(dir,s,cleanup phi1,cleanup phi2)
- | CTL.HackForStmt(dir,s,phi1,phi2) ->
- CTL.HackForStmt(dir,s,cleanup phi1,cleanup phi2)
- | CTL.And(s,phi1,phi2) -> CTL.And(s,cleanup phi1,cleanup phi2)
- | CTL.Or(phi1,phi2) -> CTL.Or(cleanup phi1,cleanup phi2)
- | CTL.SeqOr(phi1,phi2) -> CTL.SeqOr(cleanup phi1,cleanup phi2)
- | CTL.Implies(phi1,phi2) -> CTL.Implies(cleanup phi1,cleanup phi2)
- | CTL.AF(dir,s,phi1) -> CTL.AF(dir,s,cleanup phi1)
- | CTL.AX(CTL.FORWARD,s,
- CTL.Let(v1,e1,
- CTL.And(CTL.NONSTRICT,CTL.AU(CTL.FORWARD,s2,e2,e3),
- CTL.EU(CTL.FORWARD,e4,e5)))) ->
- CTL.Let(v1,e1,
- CTL.And(CTL.NONSTRICT,
- CTL.AX(CTL.FORWARD,s,CTL.AU(CTL.FORWARD,s2,e2,e3)),
- CTL.EX(CTL.FORWARD,CTL.EU(CTL.FORWARD,e4,e5))))
- | CTL.AX(dir,s,CTL.XX(phi)) -> CTL.EX(dir,cleanup phi)
- | CTL.EX(dir,CTL.XX((CTL.AU(_,s,_,_)) as phi)) ->
- CTL.AX(dir,s,cleanup phi)
- | CTL.XX(phi) -> failwith "bad XX"
- | CTL.AX(dir,s,phi1) -> CTL.AX(dir,s,cleanup phi1)
- | CTL.AG(dir,s,phi1) -> CTL.AG(dir,s,cleanup phi1)
- | CTL.EF(dir,phi1) -> CTL.EF(dir,cleanup phi1)
- | CTL.EX(dir,phi1) -> CTL.EX(dir,cleanup phi1)
- | CTL.EG(dir,phi1) -> CTL.EG(dir,cleanup phi1)
- | CTL.AW(dir,s,phi1,phi2) -> CTL.AW(dir,s,cleanup phi1,cleanup phi2)
- | CTL.AU(dir,s,phi1,phi2) -> CTL.AU(dir,s,cleanup phi1,cleanup phi2)
- | CTL.EU(dir,phi1,phi2) -> CTL.EU(dir,cleanup phi1,cleanup phi2)
- | CTL.Let (x,phi1,phi2) -> CTL.Let (x,cleanup phi1,cleanup phi2)
- | CTL.LetR (dir,x,phi1,phi2) -> CTL.LetR (dir,x,cleanup phi1,cleanup phi2)
- | CTL.Ref(s) -> CTL.Ref(s)
- | CTL.Uncheck(phi1) -> CTL.Uncheck(cleanup phi1)
- | CTL.InnerAnd(phi1) -> CTL.InnerAnd(cleanup phi1)
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-
-let top_level name (ua,pos) t =
- let ua = List.filter (function (nm,_) -> nm = name) ua in
- used_after := ua;
- saved := Ast.get_saved t;
- let quantified = Common.minus_set ua pos in
- quantify false quantified
- (match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo"
- | Ast.DECL(stmt) ->
- let unopt = elim_opt.V.rebuilder_statement stmt in
- let unopt = preprocess_dots_e unopt in
- cleanup(statement unopt VeryEnd quantified [] None None None false)
- | Ast.CODE(stmt_dots) ->
- let unopt = elim_opt.V.rebuilder_statement_dots stmt_dots in
- let unopt = preprocess_dots unopt in
- let starts_with_dots =
- match Ast.undots stmt_dots with
- d::ds ->
- (match Ast.unwrap d with
- Ast.Dots(_,_,_,_) | Ast.Circles(_,_,_,_)
- | Ast.Stars(_,_,_,_) -> true
- | _ -> false)
- | _ -> false in
- let starts_with_brace =
- match Ast.undots stmt_dots with
- d::ds ->
- (match Ast.unwrap d with
- Ast.Seq(_) -> true
- | _ -> false)
- | _ -> false in
- let res =
- statement_list unopt VeryEnd quantified [] None None None
- false false in
- cleanup
- (if starts_with_dots
- then
- (* EX because there is a loop on enter/top *)
- ctl_and CTL.NONSTRICT (toppred None) (ctl_ex res)
- else if starts_with_brace
- then
- ctl_and CTL.NONSTRICT
- (ctl_not(CTL.EX(CTL.BACKWARD,(funpred None)))) res
- else res)
- | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords")
-
-(* --------------------------------------------------------------------- *)
-(* Entry points *)
-
-let asttoctlz (name,(_,_,exists_flag),l) used_after positions =
- letctr := 0;
- labelctr := 0;
- (match exists_flag with
- Ast.Exists -> exists := Exists
- | Ast.Forall -> exists := Forall
- | Ast.ReverseForall -> exists := ReverseForall
- | Ast.Undetermined ->
- exists := if !Flag.sgrep_mode2 then Exists else Forall);
-
- let (l,used_after) =
- List.split
- (List.filter
- (function (t,_) ->
- match Ast.unwrap t with Ast.ERRORWORDS(exps) -> false | _ -> true)
- (List.combine l (List.combine used_after positions))) in
- let res = List.map2 (top_level name) used_after l in
- exists := Forall;
- res
-
-let asttoctl r used_after positions =
- match r with
- Ast.ScriptRule _ -> []
- | Ast.CocciRule (a,b,c,_,Ast_cocci.Normal) ->
- asttoctlz (a,b,c) used_after positions
- | Ast.CocciRule (a,b,c,_,Ast_cocci.Generated) -> [CTL.True]
-
-let pp_cocci_predicate (pred,modif) =
- Pretty_print_engine.pp_predicate pred
-
-let cocci_predicate_to_string (pred,modif) =
- Pretty_print_engine.predicate_to_string pred
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-module A = Ast_cocci
-module B = Ast_c
-
-module F = Control_flow_c
-
-module Flag = Flag_matcher
-
-(*****************************************************************************)
-(* Wrappers *)
-(*****************************************************************************)
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-type sequence = Ordered | Unordered
-
-let seqstyle eas =
- match A.unwrap eas with
- | A.DOTS _ -> Ordered
- | A.CIRCLES _ -> Unordered
- | A.STARS _ -> failwith "not handling stars"
-
-let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
- A.rewrap eas (
- match A.unwrap eas with
- | A.DOTS _ -> A.DOTS easundots
- | A.CIRCLES _ -> A.CIRCLES easundots
- | A.STARS _ -> A.STARS easundots
- )
-
-
-let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
- fun ibs ->
- ibs +> List.exists (fun (ib, icomma) ->
- match B.unwrap ib with
- | B.InitDesignators _
- | B.InitFieldOld _
- | B.InitIndexOld _
- -> true
- | B.InitExpr _
- | B.InitList _
- -> false
- )
-
-(* For the #include <linux/...> in the .cocci, need to find where is
- * the '+' attached to this element, to later find the first concrete
- * #include <linux/xxx.h> or last one in the serie of #includes in the
- * .c.
- *)
-type include_requirement =
- | IncludeMcodeBefore
- | IncludeMcodeAfter
- | IncludeNothing
-
-
-
-(* todo? put in semantic_c.ml *)
-type info_ident =
- | Function
- | LocalFunction (* entails Function *)
- | DontKnow
-
-
-let term mc = A.unwrap_mcode mc
-let mcodekind mc = A.get_mcodekind mc
-
-
-let mcode_contain_plus = function
- | A.CONTEXT (_,A.NOTHING) -> false
- | A.CONTEXT _ -> true
- | A.MINUS (_,[]) -> false
- | A.MINUS (_,x::xs) -> true
- | A.PLUS -> raise Impossible
-
-let mcode_simple_minus = function
- | A.MINUS (_,[]) -> true
- | _ -> false
-
-
-(* In transformation.ml sometime I build some mcodekind myself and
- * julia has put None for the pos. But there is no possible raise
- * NoMatch in those cases because it is for the minusall trick or for
- * the distribute, so either have to build those pos, in fact a range,
- * because for the distribute have to erase a fullType with one
- * mcodekind, or add an argument to tag_with_mck such as "safe" that
- * don't do the check_pos. Hence this DontCarePos constructor. *)
-
-let minusizer =
- ("fake","fake"),
- {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
- (A.MINUS(A.DontCarePos, [])),
- A.NoMetaPos
-
-let generalize_mcode ia =
- let (s1, i, mck, pos) = ia in
- let new_mck =
- match mck with
- | A.PLUS -> raise Impossible
- | A.CONTEXT (A.NoPos,x) ->
- A.CONTEXT (A.DontCarePos,x)
- | A.MINUS (A.NoPos,x) ->
- A.MINUS (A.DontCarePos,x)
-
- | A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
- | A.MINUS ((A.FixPos _|A.DontCarePos), _)
- ->
- raise Impossible
- in
- (s1, i, new_mck, pos)
-
-
-
-(*---------------------------------------------------------------------------*)
-
-(* 0x0 is equivalent to 0, value format isomorphism *)
-let equal_c_int s1 s2 =
- try
- int_of_string s1 = int_of_string s2
- with Failure("int_of_string") ->
- s1 =$= s2
-
-
-
-(*---------------------------------------------------------------------------*)
-(* Normally A should reuse some types of Ast_c, so those
- * functions should not exist.
- *
- * update: but now Ast_c depends on A, so can't make too
- * A depends on Ast_c, so have to stay with those equal_xxx
- * functions.
- *)
-
-let equal_unaryOp a b =
- match a, b with
- | A.GetRef , B.GetRef -> true
- | A.DeRef , B.DeRef -> true
- | A.UnPlus , B.UnPlus -> true
- | A.UnMinus , B.UnMinus -> true
- | A.Tilde , B.Tilde -> true
- | A.Not , B.Not -> true
- | _, B.GetRefLabel -> false (* todo cocci? *)
- | _, (B.Not|B.Tilde|B.UnMinus|B.UnPlus|B.DeRef|B.GetRef) -> false
-
-
-
-let equal_arithOp a b =
- match a, b with
- | A.Plus , B.Plus -> true
- | A.Minus , B.Minus -> true
- | A.Mul , B.Mul -> true
- | A.Div , B.Div -> true
- | A.Mod , B.Mod -> true
- | A.DecLeft , B.DecLeft -> true
- | A.DecRight , B.DecRight -> true
- | A.And , B.And -> true
- | A.Or , B.Or -> true
- | A.Xor , B.Xor -> true
- | _, (B.Xor|B.Or|B.And|B.DecRight|B.DecLeft|B.Mod|B.Div|B.Mul|B.Minus|B.Plus)
- -> false
-
-let equal_logicalOp a b =
- match a, b with
- | A.Inf , B.Inf -> true
- | A.Sup , B.Sup -> true
- | A.InfEq , B.InfEq -> true
- | A.SupEq , B.SupEq -> true
- | A.Eq , B.Eq -> true
- | A.NotEq , B.NotEq -> true
- | A.AndLog , B.AndLog -> true
- | A.OrLog , B.OrLog -> true
- | _, (B.OrLog|B.AndLog|B.NotEq|B.Eq|B.SupEq|B.InfEq|B.Sup|B.Inf)
- -> false
-
-let equal_assignOp a b =
- match a, b with
- | A.SimpleAssign, B.SimpleAssign -> true
- | A.OpAssign a, B.OpAssign b -> equal_arithOp a b
- | _, (B.OpAssign _|B.SimpleAssign) -> false
-
-let equal_fixOp a b =
- match a, b with
- | A.Dec, B.Dec -> true
- | A.Inc, B.Inc -> true
- | _, (B.Inc|B.Dec) -> false
-
-let equal_binaryOp a b =
- match a, b with
- | A.Arith a, B.Arith b -> equal_arithOp a b
- | A.Logical a, B.Logical b -> equal_logicalOp a b
- | _, (B.Logical _ | B.Arith _) -> false
-
-let equal_structUnion a b =
- match a, b with
- | A.Struct, B.Struct -> true
- | A.Union, B.Union -> true
- | _, (B.Struct|B.Union) -> false
-
-let equal_sign a b =
- match a, b with
- | A.Signed, B.Signed -> true
- | A.Unsigned, B.UnSigned -> true
- | _, (B.UnSigned|B.Signed) -> false
-
-let equal_storage a b =
- match a, b with
- | A.Static , B.Sto B.Static
- | A.Auto , B.Sto B.Auto
- | A.Register , B.Sto B.Register
- | A.Extern , B.Sto B.Extern
- -> true
- | _, (B.NoSto | B.StoTypedef) -> false
- | _, (B.Sto (B.Register|B.Static|B.Auto|B.Extern)) -> false
-
-
-(*---------------------------------------------------------------------------*)
-
-let equal_metavarval valu valu' =
- match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
- | Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
- | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
- (* do something more ? *)
- a =$= b
-
- (* al_expr before comparing !!! and accept when they match.
- * Note that here we have Astc._expression, so it is a match
- * modulo isomorphism (there is no metavariable involved here,
- * just isomorphisms). => TODO call isomorphism_c_c instead of
- * =*=. Maybe would be easier to transform ast_c in ast_cocci
- * and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
- Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
- | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
- Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
-
- | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
- Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
- | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
- (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
- C_vs_c.eq_type a b
-
- | Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
-
- | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
- Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
- | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
- Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
-
- | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
- Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
-
- | Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
- List.exists
- (function (fla,cea,posa1,posa2) ->
- List.exists
- (function (flb,ceb,posb1,posb2) ->
- fla = flb && cea = ceb &&
- Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
- l2)
- l1
-
- | (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
- |B.MetaTypeVal _
- |B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
- |B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
- ), _
- -> raise Impossible
-
-
-(*---------------------------------------------------------------------------*)
-(* could put in ast_c.ml, next to the split/unsplit_comma *)
-let split_signb_baseb_ii (baseb, ii) =
- let iis = ii +> List.map (fun info -> (B.str_of_info info), info) in
- match baseb, iis with
-
- | B.Void, ["void",i1] -> None, [i1]
-
- | B.FloatType (B.CFloat),["float",i1] -> None, [i1]
- | B.FloatType (B.CDouble),["double",i1] -> None, [i1]
- | B.FloatType (B.CLongDouble),["long",i1;"double",i2] -> None,[i1;i2]
-
- | B.IntType (B.CChar), ["char",i1] -> None, [i1]
-
-
- | B.IntType (B.Si (sign, base)), xs ->
- (match sign, base, xs with
- | B.Signed, B.CChar2, ["signed",i1;"char",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CChar2, ["unsigned",i1;"char",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CShort, ["short",i1] ->
- None, [i1]
- | B.Signed, B.CShort, ["signed",i1;"short",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2] ->
- Some (B.UnSigned, i1), [i2]
- | B.Signed, B.CShort, ["short",i1;"int",i2] ->
- None, [i1;i2]
-
- | B.Signed, B.CInt, ["int",i1] ->
- None, [i1]
- | B.Signed, B.CInt, ["signed",i1;"int",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CInt, ["unsigned",i1;"int",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CInt, ["signed",i1;] ->
- Some (B.Signed, i1), []
- | B.UnSigned, B.CInt, ["unsigned",i1;] ->
- Some (B.UnSigned, i1), []
-
- | B.Signed, B.CLong, ["long",i1] ->
- None, [i1]
- | B.Signed, B.CLong, ["long",i1;"int",i2] ->
- None, [i1;i2]
- | B.Signed, B.CLong, ["signed",i1;"long",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CLong, ["unsigned",i1;"long",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CLongLong, ["long",i1;"long",i2] -> None, [i1;i2]
- | B.Signed, B.CLongLong, ["signed",i1;"long",i2;"long",i3] ->
- Some (B.Signed, i1), [i2;i3]
- | B.UnSigned, B.CLongLong, ["unsigned",i1;"long",i2;"long",i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2; "int", i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
-
- | _ -> failwith "strange type1, maybe because of weird order"
- )
- | _ -> failwith "strange type2, maybe because of weird order"
-
-(*---------------------------------------------------------------------------*)
-
-let rec unsplit_icomma xs =
- match xs with
- | [] -> []
- | x::y::xs ->
- (match A.unwrap y with
- | A.IComma mcode ->
- (x, y)::unsplit_icomma xs
- | _ -> failwith "wrong ast_cocci in initializer"
- )
- | _ ->
- failwith ("wrong ast_cocci in initializer, should have pair " ^
- "number of Icomma")
-
-
-
-let resplit_initialiser ibs iicomma =
- match iicomma, ibs with
- | [], [] -> []
- | [], _ ->
- failwith "should have a iicomma, do you generate fakeInfo in parser?"
- | _, [] ->
- failwith "shouldn't have a iicomma"
- | [iicomma], x::xs ->
- let elems = List.map fst (x::xs) in
- let commas = List.map snd (x::xs) +> List.flatten in
- let commas = commas @ [iicomma] in
- zip elems commas
- | _ -> raise Impossible
-
-
-
-let rec split_icomma xs =
- match xs with
- | [] -> []
- | (x,y)::xs -> x::y::split_icomma xs
-
-let rec unsplit_initialiser ibs_unsplit =
- match ibs_unsplit with
- | [] -> [], [] (* empty iicomma *)
- | (x, commax)::xs ->
- let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
- (x, [])::xs, lastcomma
-
-and unsplit_initialiser_bis comma_before = function
- | [] -> [], [comma_before]
- | (x, commax)::xs ->
- let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
- (x, [comma_before])::xs, lastcomma
-
-
-
-
-(*---------------------------------------------------------------------------*)
-(* coupling: same in type_annotater_c.ml *)
-let structdef_to_struct_name ty =
- match ty with
- | qu, (B.StructUnion (su, sopt, fields), iis) ->
- (match sopt,iis with
- | Some s , [i1;i2;i3;i4] ->
- qu, (B.StructUnionName (su, s), [i1;i2])
- | None, _ ->
- ty
-
- | x -> raise Impossible
- )
- | _ -> raise Impossible
-
-(*---------------------------------------------------------------------------*)
-let initialisation_to_affectation decl =
- match decl with
- | B.MacroDecl _ -> F.Decl decl
- | B.DeclList (xs, iis) ->
-
- (* todo?: should not do that if the variable is an array cos
- * will have x[] = , mais de toute facon ca sera pas un InitExp
- *)
- (match xs with
- | [] -> raise Impossible
- | [x] ->
- let ({B.v_namei = var;
- B.v_type = returnType;
- B.v_storage = storage;
- B.v_local = local},
- iisep) = x in
-
- (match var with
- | Some ((s, ini), iis::iini) ->
- (match ini with
- | Some (B.InitExpr e, ii_empty2) ->
- let local =
- match local with
- Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
- | Ast_c.LocalDecl -> Ast_c.LocalVar (iis.Ast_c.pinfo) in
-
- let typ =
- ref (Some ((Lib_parsing_c.al_type returnType),local),
- Ast_c.NotTest) in
- let id = (B.Ident s, typ),[iis] in
- F.DefineExpr
- ((B.Assignment (id, B.SimpleAssign, e),
- Ast_c.noType()), iini)
- | _ -> F.Decl decl
- )
- | _ -> F.Decl decl
- )
- | x::xs ->
- pr2_once "TODO: initialisation_to_affectation for multi vars";
- (* todo? do a fold_left and generate 'x = a, y = b' etc, use
- * the Sequence expression operator of C and make an
- * ExprStatement from that.
- *)
- F.Decl decl
- )
-
-
-
-
-
-(*****************************************************************************)
-(* Functor parameter combinators *)
-(*****************************************************************************)
-(* monad like stuff
- * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
- *
- * version0: was not tagging the SP, so just tag the C
- * val (>>=):
- * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
- * val return : 'b -> tin -> 'b tout
- * val fail : tin -> 'b tout
- *
- * version1: now also tag the SP so return a ('a * 'b)
- *)
-
-type mode = PatternMode | TransformMode
-
-module type PARAM =
- sig
- type tin
- type 'x tout
-
-
- type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
-
- val mode : mode
-
- val (>>=):
- (tin -> ('a * 'b) tout) ->
- ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
- (tin -> ('c * 'd) tout)
-
- val return : ('a * 'b) -> tin -> ('a *'b) tout
- val fail : tin -> ('a * 'b) tout
-
- val (>||>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>|+|>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>&&>) : (tin -> bool) -> (tin -> 'x tout) -> (tin -> 'x tout)
-
- val tokenf : ('a A.mcode, B.info) matcher
- val tokenf_mck : (A.mcodekind, B.info) matcher
-
- val distrf_e :
- (A.meta_name A.mcode, B.expression) matcher
- val distrf_args :
- (A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
- val distrf_type :
- (A.meta_name A.mcode, Ast_c.fullType) matcher
- val distrf_params :
- (A.meta_name A.mcode,
- (Ast_c.parameterType, Ast_c.il) either list) matcher
- val distrf_param :
- (A.meta_name A.mcode, Ast_c.parameterType) matcher
- val distrf_ini :
- (A.meta_name A.mcode, Ast_c.initialiser) matcher
- val distrf_node :
- (A.meta_name A.mcode, Control_flow_c.node) matcher
-
- val distrf_define_params :
- (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
- matcher
-
- val distrf_struct_fields :
- (A.meta_name A.mcode, B.field list) matcher
-
- val distrf_cst :
- (A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
-
- val cocciExp :
- (A.expression, B.expression) matcher -> (A.expression, F.node) matcher
-
- val cocciExpExp :
- (A.expression, B.expression) matcher ->
- (A.expression, B.expression) matcher
-
- val cocciTy :
- (A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
-
- val cocciInit :
- (A.initialiser, B.initialiser) matcher -> (A.initialiser, F.node) matcher
-
- val envf :
- A.keep_binding -> A.inherited ->
- A.meta_name A.mcode * Ast_c.metavar_binding_kind *
- (unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val check_constraints :
- ('a, 'b) matcher -> 'a list -> 'b ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val all_bound : A.meta_name list -> (tin -> bool)
-
- val optional_storage_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
-
-
- end
-
-(*****************************************************************************)
-(* Functor code, "Cocci vs C" *)
-(*****************************************************************************)
-
-module COCCI_VS_C =
- functor (X : PARAM) ->
-struct
-
-type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
-
-let (>>=) = X.(>>=)
-let return = X.return
-let fail = X.fail
-
-let (>||>) = X.(>||>)
-let (>|+|>) = X.(>|+|>)
-let (>&&>) = X.(>&&>)
-
-let tokenf = X.tokenf
-
-(* should be raise Impossible when called from transformation.ml *)
-let fail2 () =
- match X.mode with
- | PatternMode -> fail
- | TransformMode -> raise Impossible
-
-
-let (option: ('a,'b) matcher -> ('a option,'b option) matcher)= fun f t1 t2 ->
- match (t1,t2) with
- | (Some t1, Some t2) ->
- f t1 t2 >>= (fun t1 t2 ->
- return (Some t1, Some t2)
- )
- | (None, None) -> return (None, None)
- | _ -> fail
-
-(* Dots are sometimes used as metavariables, since like metavariables they
-can match other things. But they no longer have the same type. Perhaps these
-functions could be avoided by introducing an appropriate level of polymorphism,
-but I don't know how to declare polymorphism across functors *)
-let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
-let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
-
-(*---------------------------------------------------------------------------*)
-(* toc:
- * - expression
- * - ident
- * - arguments
- * - parameters
- * - declaration
- * - initialisers
- * - type
- * - node
- *)
-
-(*---------------------------------------------------------------------------*)
-let rec (expression: (A.expression, Ast_c.expression) matcher) =
- fun ea eb ->
- X.all_bound (A.get_inherited ea) >&&>
- let wa x = A.rewrap ea x in
- match A.unwrap ea, eb with
-
- (* general case: a MetaExpr can match everything *)
- | A.MetaExpr (ida,constraints,keep,opttypa,form,inherited),
- (((expr, opttypb), ii) as expb) ->
-
- (* old: before have a MetaConst. Now we factorize and use 'form' to
- * differentiate between different cases *)
- let rec matches_id = function
- B.Ident(c) -> true
- | B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
- | _ -> false in
- let form_ok =
- match (form,expr) with
- (A.ANY,_) -> true
- | (A.CONST,e) ->
- let rec matches = function
- B.Constant(c) -> true
- | B.Ident idb when idb =~ "^[A-Z_][A-Z_0-9]*$" ->
- pr2_once ("warning: I consider " ^ idb ^ " as a constant");
- true
- | B.Cast(ty,e) -> matches (B.unwrap_expr e)
- | B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
- | B.SizeOfExpr(exp) -> true
- | B.SizeOfType(ty) -> true
- | _ -> false in
- matches e
- | (A.LocalID,e) ->
- (matches_id e) &&
- (match !opttypb with
- (Some (_,Ast_c.LocalVar _),_) -> true
- | _ -> false)
- | (A.ID,e) -> matches_id e in
-
- if form_ok
- then
- (let (opttypb,_testb) = !opttypb in
- match opttypa, opttypb with
- | None, _ -> return ((),())
- | Some _, None ->
- pr2_once ("Missing type information. Certainly a pb in " ^
- "annotate_typer.ml");
- fail
-
- | Some tas, Some tb ->
- tas +> List.fold_left (fun acc ta ->
- acc >|+|> compatible_type ta tb) fail
- ) >>=
- (fun () () ->
- X.check_constraints expression constraints eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>= (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )))
- else fail
-
- (* old:
- * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
- * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
- *
- * but bug! because if have not tagged SP, then transform without doing
- * any checks. Hopefully now have tagged SP technique.
- *)
-
-
- (* old:
- * | A.Edots _, _ -> raise Impossible.
- *
- * In fact now can also have the Edots inside normal expression, not
- * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
- *)
- | A.Edots (mcode, None), expb ->
- X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
- return (
- A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
- expb
- ))
-
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
-
- | A.Ident ida, ((B.Ident idb, typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- return (
- ((A.Ident ida)) +> wa,
- ((B.Ident idb, typ),[ib1])
- ))
-
-
-
-
- | A.MetaErr _, _ -> failwith "not handling MetaErr"
-
- (* todo?: handle some isomorphisms in int/float ? can have different
- * format : 1l can match a 1.
- *
- * todo: normally string can contain some metavar too, so should
- * recurse on the string
- *)
- | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
- (* for everything except the String case where can have multi elems *)
- let do1 () =
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
- ((B.Constant (ib), typ),[ib1])
- ))
- in
- (match term ia1, ib with
- | A.Int x, B.Int y ->
- X.value_format_flag (fun use_value_equivalence ->
- if use_value_equivalence
- then
- if equal_c_int x y
- then do1()
- else fail
- else
- if x =$= y
- then do1()
- else fail
- )
- | A.Char x, B.Char (y,_) when x =$= y (* todo: use kind ? *)
- -> do1()
- | A.Float x, B.Float (y,_) when x =$= y (* todo: use floatType ? *)
- -> do1()
-
- | A.String sa, B.String (sb,_kind) when sa =$= sb ->
- (match ii with
- | [ib1] ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
- ((B.Constant (ib), typ),[ib1])
- ))
- | _ -> fail (* multi string, not handled *)
- )
-
- | _, B.MultiString -> (* todo cocci? *) fail
- | _, (B.String _ | B.Float _ | B.Char _ | B.Int _) -> fail
- )
-
-
- | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
- (* todo: do special case to allow IdMetaFunc, cos doing the
- * recursive call will be too late, match_ident will not have the
- * info whether it was a function. todo: but how detect when do
- * x.field = f; how know that f is a Func ? By having computed
- * some information before the matching!
- *
- * Allow match with FunCall containing types. Now ast_cocci allow
- * type in parameter, and morover ast_cocci allow f(...) and those
- * ... could match type.
- *)
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- ((A.FunCall (ea, ia1, eas, ia2)) +> wa,
- ((B.FunCall (eb, ebs),typ), [ib1;ib2])
- ))))))
-
-
-
-
- | A.Assignment (ea1, opa, ea2, simple),
- ((B.Assignment (eb1, opb, eb2), typ),ii) ->
- let (opbi) = tuple_of_list1 ii in
- if equal_assignOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
- ((B.Assignment (eb1, opb, eb2), typ), [opbi])
- ))))
- else fail
-
- | A.CondExpr(ea1,ia1,ea2opt,ia2,ea3),((B.CondExpr(eb1,eb2opt,eb3),typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- expression ea3 eb3 >>= (fun ea3 eb3 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.CondExpr(ea1,ia1,ea2opt,ia2,ea3))) +> wa,
- ((B.CondExpr (eb1, eb2opt, eb3),typ), [ib1;ib2])
- ))))))
-
- (* todo?: handle some isomorphisms here ? *)
- | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_fixOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Postfix (ea, opa))) +> wa,
- ((B.Postfix (eb, opb), typ),[opbi])
- )))
- else fail
-
-
- | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_fixOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Infix (ea, opa))) +> wa,
- ((B.Infix (eb, opb), typ),[opbi])
- )))
- else fail
-
- | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_unaryOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Unary (ea, opa))) +> wa,
- ((B.Unary (eb, opb), typ),[opbi])
- )))
- else fail
-
- | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_binaryOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Binary (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))
- else fail
-
- | A.Nested (ea1, opa, ea2), eb ->
- let rec loop eb =
- (if A.get_test_exp ea1 && not (Ast_c.is_test eb) then fail
- else expression ea1 eb) >|+|>
- (match eb with
- ((B.Binary (eb1, opb, eb2), typ),ii)
- when equal_binaryOp (term opa) opb ->
- let opbi = tuple_of_list1 ii in
- let left_to_right =
- (expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let right_to_left =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- expression ea1 eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let in_left =
- (loop eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let in_right =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- loop eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
- | _ -> fail) in
- loop eb
-
- (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
- | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.ArrayAccess (ea1, ia1, ea2, ia2))) +> wa,
- ((B.ArrayAccess (eb1, eb2),typ), [ib1;ib2])
- )))))
-
- (* todo?: handle some isomorphisms here ? *)
- | A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
- return (
- ((A.RecordAccess (ea, ia1, ida))) +> wa,
- ((B.RecordAccess (eb, idb), typ), [ib1;ib2])
- ))))
-
-
-
- | A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
- return (
- ((A.RecordPtAccess (ea, ia1, ida))) +> wa,
- ((B.RecordPtAccess (eb, idb), typ), [ib1;ib2])
- ))))
-
-
- (* todo?: handle some isomorphisms here ?
- * todo?: do some iso-by-absence on cast ?
- * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
- *)
-
- | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.Cast (ia1, typa, ia2, ea))) +> wa,
- ((B.Cast (typb, eb),typ),[ib1;ib2])
- )))))
-
- | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.SizeOfExpr (ia1, ea))) +> wa,
- ((B.SizeOfExpr (eb), typ),[ib1])
- )))
-
- | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- ((A.SizeOfType (ia1, ia2, typa, ia3))) +> wa,
- ((B.SizeOfType (typb),typ),[ib1;ib2;ib3])
- )))))
-
-
- (* todo? iso ? allow all the combinations ? *)
- | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.Paren (ia1, ea, ia2))) +> wa,
- ((B.ParenExpr (eb), typ), [ib1;ib2])
- ))))
-
- | A.NestExpr(exps,None,true), eb ->
- (match A.unwrap exps with
- A.DOTS [exp] ->
- X.cocciExpExp expression exp eb >>= (fun exp eb ->
- return (
- (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
- eb
- )
- )
- | _ ->
- failwith
- "for nestexpr, only handling the case with dots and only one exp")
-
- | A.NestExpr _, _ ->
- failwith "only handling multi and no when code in a nest expr"
-
- (* only in arg lists or in define body *)
- | A.TypeExp _, _ -> fail
-
- (* only in arg lists *)
- | A.MetaExprList _, _
- | A.EComma _, _
- | A.Ecircles _, _
- | A.Estars _, _
- ->
- raise Impossible
-
- | A.DisjExpr eas, eb ->
- eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
-
- | A.UniqueExp _,_ | A.OptExp _,_ ->
- failwith "not handling Opt/Unique/Multi on expr"
-
- (* Because of Exp cant put a raise Impossible; have to put a fail *)
-
- (* have not a counter part in coccinelle, for the moment *)
- | _, ((B.Sequence _,_),_)
- | _, ((B.StatementExpr _,_),_)
- | _, ((B.Constructor _,_),_)
- -> fail
-
-
- | _,
- (((B.Cast (_, _)|B.ParenExpr _|B.SizeOfType _|B.SizeOfExpr _|
- B.RecordPtAccess (_, _)|
- B.RecordAccess (_, _)|B.ArrayAccess (_, _)|
- B.Binary (_, _, _)|B.Unary (_, _)|
- B.Infix (_, _)|B.Postfix (_, _)|
- B.Assignment (_, _, _)|B.CondExpr (_, _, _)|
- B.FunCall (_, _)|B.Constant _|B.Ident _),
- _),_)
- -> fail
-
-
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
- fun infoidb ida ((idb, iib) as ib) ->
- X.all_bound (A.get_inherited ida) >&&>
- match A.unwrap ida with
- | A.Id sa ->
- if (term sa) =$= idb then
- tokenf sa iib >>= (fun sa iib ->
- return (
- ((A.Id sa)) +> A.rewrap ida,
- (idb, iib)
- ))
- else fail
-
-
- | A.MetaId(mida,constraints,keep,inherited) ->
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- (* use drop_pos for ids so that the pos is not added a second time in
- the call to tokenf *)
- X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
- (idb, iib)
- )))
- ))
-
- | A.MetaFunc(mida,constraints,keep,inherited) ->
- let is_function _ =
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
- (idb, iib)
- ))
- )) in
- (match infoidb with
- | LocalFunction | Function -> is_function()
- | DontKnow ->
- failwith "MetaFunc, need more semantic info about id"
- (* the following implementation could possibly be useful, if one
- follows the convention that a macro is always in capital letters
- and that a macro is not a function.
- (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
- )
-
- | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
- (match infoidb with
- | LocalFunction ->
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- X.envf keep inherited
- (A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaLocalFunc(mida,constraints,keep,inherited)))
- +> A.rewrap ida,
- (idb, iib)
- ))
- ))
- | Function -> fail
- | DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
- )
-
- | A.OptIdent _ | A.UniqueIdent _ ->
- failwith "not handling Opt/Unique for ident"
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (arguments: sequence ->
- (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-(* because '...' can match nothing, need to take care when have
- * ', ...' or '...,' as in f(..., X, Y, ...). It must match
- * f(1,2) for instance.
- * So I have added special cases such as (if startxs = []) and code
- * in the Ecomma matching rule.
- *
- * old: Must do some try, for instance when f(...,X,Y,...) have to
- * test the transfo for all the combinaitions and if multiple transfo
- * possible ? pb ? => the type is to return a expression option ? use
- * some combinators to help ?
- * update: with the tag-SP approach, no more a problem.
- *)
-
-and arguments_bis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Edots (mcode, optexpr), ys ->
- (* todo: if optexpr, then a WHEN and so may have to filter yys *)
- if optexpr <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (* allow '...', and maybe its associated ',' to match nothing.
- * for the associated ',' see below how we handle the EComma
- * to match nothing.
- *)
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (* subtil: we dont want the '...' to match until the
- * comma. cf -test pb_params_iso. We would get at
- * "already tagged" error.
- * this is because both f (... x, ...) and f (..., x, ...)
- * would match a f(x,3) with our "optional-comma" strategy.
- *)
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_args (dots2metavar mcode) startxs
- )
- )
- >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.EComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.EComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
- | A.EComma ia1, ebs ->
- (* allow ',' to maching nothing. optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else arguments_bis eas ebs
-
- | A.MetaExprList(ida,leninfo,keep,inherited),ys ->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- | Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_args startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaExprListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_args ida (Ast_c.split_comma startxs')
- )
- >>= (fun ida startxs ->
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaExprList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- )
- )) fail
-
-
- | _unwrapx, (Left eb)::ebs ->
- argument ea eb >>= (fun ea eb ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (ea::eas, Left eb::ebs)
- ))
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-and argument arga argb =
- X.all_bound (A.get_inherited arga) >&&>
- match A.unwrap arga, argb with
- | A.TypeExp tya, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
-
- if b || sopt <> None
- then
- (* failwith "the argument have a storage and ast_cocci does not have"*)
- fail
- else
- fullType tya tyb >>= (fun tya tyb ->
- return (
- (A.TypeExp tya) +> A.rewrap arga,
- (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
- ))
-
- | A.TypeExp tya, _ -> fail
- | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
- | _, Left argb ->
- expression arga argb >>= (fun arga argb ->
- return (arga, Left argb)
- )
- | _, Right (B.ArgAction y) -> fail
-
-
-(* ------------------------------------------------------------------------- *)
-(* todo? facto code with argument ? *)
-and (parameters: sequence ->
- (A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
- matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-
-and parameters_bis eas ebs =
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- (* the management of positions is inlined into each case, because
- sometimes there is a Param and sometimes a ParamList *)
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Pdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on"*)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Pdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.PComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.PComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.PComma ia1, ebs ->
- (* try optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else parameters_bis eas ebs
-
-
- | A.MetaParamList(ida,leninfo,keep,inherited),ys->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "I have no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_params startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaParamListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_params ida (Ast_c.split_comma startxs')
- ) >>= (fun ida startxs ->
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaParamList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- ))
- ) fail
-
-
- | A.VoidParam ta, ys ->
- (match eas, ebs with
- | [], [Left eb] ->
- let ((hasreg, idbopt, tb), ii_b_s) = eb in
- if idbopt = None && null ii_b_s
- then
- match tb with
- | (qub, (B.BaseType B.Void,_)) ->
- fullType ta tb >>= (fun ta tb ->
- return (
- [(A.VoidParam ta) +> A.rewrap ea],
- [Left ((hasreg, idbopt, tb), ii_b_s)]
- ))
- | _ -> fail
- else fail
- | _ -> fail
- )
-
- | (A.OptParam _ | A.UniqueParam _), _ ->
- failwith "handling Opt/Unique for Param"
-
- | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
-
- | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
- (* todo: use quaopt, hasreg ? *)
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
- X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
- X.distrf_param ida eb
- ) >>= (fun ida eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
- (Left eb)::ebs
- )))
-
-
- | A.Param (typa, idaopt), (Left eb)::ebs ->
- (*this should succeed if the C code has a name, and fail otherwise*)
- parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
- (Left eb)::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-
-
-and parameter = fun (idaopt, typa) ((hasreg, idbopt, typb), ii_b_s) ->
- fullType typa typb >>= (fun typa typb ->
- match idaopt, Ast_c.split_register_param (hasreg, idbopt, ii_b_s) with
- | Some ida, Left (idb, iihasreg, iidb) ->
- (* todo: if minus on ida, should also minus the iihasreg ? *)
- ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
- return (
- (Some ida, typa),
- ((hasreg, Some idb, typb), iihasreg++[iidb])
- ))
-
- | None, Right iihasreg ->
- return (
- (None, typa),
- ((hasreg, None, typb), iihasreg)
- )
-
-
- (* why handle this case ? because of transform_proto ? we may not
- * have an ident in the proto.
- * If have some plus on ida ? do nothing about ida ?
- *)
- (* not anymore !!! now that julia is handling the proto.
- | _, Right iihasreg ->
- return (
- (idaopt, typa),
- ((hasreg, None, typb), iihasreg)
- )
- *)
-
- | Some _, Right _ -> fail
- | None, Left _ -> fail
- )
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
- fun (mckstart, allminus, decla) declb ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
- * de toutes les declarations qui sont au debut d'un fonction et
- * commencer le reste du match au premier statement. Alors, ca matche
- * n'importe quelle declaration. On n'a pas besoin d'ajouter
- * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
- *
- * When the SP want to remove the whole function, the minus is not
- * on the MetaDecl but on the MetaRuleElem. So there should
- * be no transform of MetaDecl, just matching are allowed.
- *)
-
- | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
- (* todo: should not happen in transform mode *)
- return ((mckstart, allminus, decla), declb)
-
-
-
- | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
- onedecl allminus decla (var,iiptvirgb,iisto) >>=
- (fun decla (var,iiptvirgb,iisto)->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))
-
- | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
- if X.mode = PatternMode
- then
- xs +> List.fold_left (fun acc var ->
- acc >||> (
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- onedecl allminus decla (var, iiptvirgb, iisto) >>=
- (fun decla (var, iiptvirgb, iisto) ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))))
- fail
- else
- failwith "More that one variable in decl. Have to split to transform."
-
- | A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
- let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
- (match ii with
- | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
- (iisb,lpb,rpb,iiendb, iifakestart,iisto)
- | _ -> raise Impossible
- ) in
- (if allminus
- then minusize_list iistob
- else return ((), iistob)
- ) >>= (fun () iistob ->
-
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- ident DontKnow sa (sb, iisb) >>= (fun sa (sb, iisb) ->
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- tokenf enda iiendb >>= (fun enda iiendb ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
-
- return (
- (mckstart, allminus,
- (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
- (B.MacroDecl ((sb,ebs),
- [iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
- ))))))))
-
- | _, (B.MacroDecl _ |B.DeclList _) -> fail
-
-
-
-and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* kind of typedef iso, we must unfold, it's for the case
- * T { }; that we want to match against typedef struct { } xx_t;
- *)
- | A.TyDecl (tya0, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- (match A.unwrap tya0, typb0 with
- | A.Type(cv1,tya1), ((qu,il),typb1) ->
-
- (match A.unwrap tya1, typb1 with
- | A.StructUnionDef(tya2, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
-
- let (iisub, iisbopt, lbb, rbb) =
- match sbopt with
- | None ->
- let (iisub, lbb, rbb) = tuple_of_list3 ii in
- (iisub, [], lbb, rbb)
- | Some s ->
- pr2 (sprintf
- "warning: both a typedef (%s) and struct name introduction (%s)"
- idb s
- );
- pr2 "warning: I will consider only the typedef";
- let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
- (iisub, [iisb], lbb, rbb)
- in
- let structnameb =
- structdef_to_struct_name
- (Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
- in
- let fake_typeb =
- Ast_c.nQ,((B.TypeName (idb, Some
- (Lib_parsing_c.al_type structnameb))), [iidb])
- in
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
- struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
- let declsa = redots declsa undeclsa in
-
- (match A.unwrap tya2 with
- | A.Type(cv3, tya3) ->
- (match A.unwrap tya3 with
- | A.MetaType(ida,keep, inherited) ->
-
- fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
- let tya1 =
- A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1 in
- let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
-
- let typb1 = B.StructUnion (sub,sbopt, declsb),
- [iisub] @ iisbopt @ [lbb;rbb] in
- let typb0 = ((qu, il), typb1) in
-
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
-
- | A.StructUnionName(sua, sa) ->
-
- fullType tya2 structnameb >>= (fun tya2 structnameb ->
-
- let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
- in
- let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
- match structnameb with
- | _nQ, (B.StructUnionName (sub, s), [iisub;iisbopt]) ->
-
- let typb1 = B.StructUnion (sub,sbopt, declsb),
- [iisub;iisbopt;lbb;rbb] in
- let typb0 = ((qu, il), typb1) in
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
- | _ -> raise Impossible
- )
- | _ -> fail
- )))))
- | _ -> fail
- )
- | _ -> fail
- )
-
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
-
-
-
- (* could handle iso here but handled in standard.iso *)
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- return (
- (A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb,None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg),
- iiptvirgb,iistob)
- )))))
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg)
- ->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf eqa iieqb >>= (fun eqa iieqb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg),
- iiptvirgb,iistob)
- )))))))
-
- (* do iso-by-absence here ? allow typedecl and var ? *)
- | A.TyDecl (typa, ptvirga),
- ({B.v_namei = None; B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- if stob = (B.NoSto, false)
- then
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- return (
- (A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = None;
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg), iiptvirgb, iistob)
- )))
- else fail
-
-
- | A.Typedef (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = (B.StoTypedef,inline);
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- (match iistob with
- | [iitypedef] ->
- tokenf stoa iitypedef >>= (fun stoa iitypedef ->
- return (stoa, [iitypedef])
- )
- | _ -> failwith "wierd, have both typedef and inline or nothing";
- ) >>= (fun stoa iistob ->
- (match A.unwrap ida with
- | A.MetaType(_,_,_) ->
-
- let fake_typeb =
- Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
- in
- fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
- return (ida, (idb, iidb))
- | _ -> raise Impossible
- )
-
- | A.TypeName sa ->
- if (term sa) =$= idb
- then
- tokenf sa iidb >>= (fun sa iidb ->
- return (
- (A.TypeName sa) +> A.rewrap ida,
- (idb, iidb)
- ))
- else fail
- | _ -> raise Impossible
-
- ) >>= (fun ida (idb, iidb) ->
- return (
- (A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = (B.StoTypedef,inline);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),
- iiptvirgb, iistob)
- )
- ))))
-
-
- | _, ({B.v_namei = None;}, _) ->
- (* old: failwith "no variable in this declaration, wierd" *)
- fail
-
-
-
- | A.DisjDecl declas, declb ->
- declas +> List.fold_left (fun acc decla ->
- acc >|+|>
- (* (declaration (mckstart, allminus, decla) declb) *)
- (onedecl allminus decla (declb,iiptvirgb, iistob))
- ) fail
-
-
-
- (* only in struct type decls *)
- | A.Ddots(dots,whencode), _ ->
- raise Impossible
-
- | A.OptDecl _, _ | A.UniqueDecl _, _ ->
- failwith "not handling Opt/Unique Decl"
-
- | _, ({B.v_namei=Some _}, _)
- -> fail
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-
-and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
- X.all_bound (A.get_inherited ia) >&&>
- match (A.unwrap ia,ib) with
-
- | (A.InitExpr expa, ib) ->
- (match A.unwrap expa, ib with
- | A.Edots (mcode, None), ib ->
- X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
- return (
- A.InitExpr
- (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
- +> A.rewrap ia,
- ib
- ))
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
- | _, (B.InitExpr expb, ii) ->
- assert (null ii);
- expression expa expb >>= (fun expa expb ->
- return (
- (A.InitExpr expa) +> A.rewrap ia,
- (B.InitExpr expb, ii)
- ))
- | _ -> fail
- )
-
- | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
- (match ii with
- | ib1::ib2::iicommaopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
- return (
- (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
- (B.InitList ibs, ib1::ib2::iicommaopt)
- ))))
-
- | _ -> raise Impossible
- )
-
- | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
- failwith "TODO: not handling whencode in initialisers"
-
-
- | (A.InitGccDotName (ia1, ida, ia2, inia),
- (B.InitDesignators ([B.DesignatorField idb,ii1], inib), ii2))->
-
- let (iidot, iidb) = tuple_of_list2 ii1 in
- let iieq = tuple_of_list1 ii2 in
-
- tokenf ia1 iidot >>= (fun ia1 iidot ->
- tokenf ia2 iieq >>= (fun ia2 iieq ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccDotName (ia1, ida, ia2, inia)) +> A.rewrap ia,
- (B.InitDesignators
- ([B.DesignatorField idb, [iidot;iidb]], inib), [iieq])
- )))))
-
-
- | (A.InitGccIndex (ia1,ea,ia2,ia3,inia),
- (B.InitDesignators ([B.DesignatorIndex eb, ii1], inib), ii2)) ->
-
- let (ib1, ib2) = tuple_of_list2 ii1 in
- let ib3 = tuple_of_list1 ii2 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression ea eb >>= (fun ea eb ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccIndex (ia1,ea,ia2,ia3,inia)) +> A.rewrap ia,
- (B.InitDesignators
- ([B.DesignatorIndex eb, [ib1;ib2]], inib), [ib3])
- ))))))
-
-
- | (A.InitGccRange (ia1,e1a,ia2,e2a,ia3,ia4,inia),
- (B.InitDesignators ([B.DesignatorRange (e1b, e2b), ii1], inib), ii2)) ->
-
- let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
- let (ib4) = tuple_of_list1 ii2 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- expression e1a e1b >>= (fun e1a e1b ->
- expression e2a e2b >>= (fun e2a e2b ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccRange (ia1,e1a,ia2,e2a,ia3,ia4,inia)) +> A.rewrap ia,
- (B.InitDesignators
- ([B.DesignatorRange (e1b, e2b),[ib1;ib2;ib3]], inib), [ib4])
- ))))))))
-
-
-
-
- | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
- (match ii with
- | [iidb;iicolon] ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- initialiser inia inib >>= (fun inia inib ->
- tokenf ia1 iicolon >>= (fun ia1 iicolon ->
- return (
- (A.InitGccName (ida, ia1, inia)) +> A.rewrap ia,
- (B.InitFieldOld (idb, inib), [iidb;iicolon])
- ))))
- | _ -> fail
- )
-
-
-
- | A.IComma(comma), _ ->
- raise Impossible
-
- | A.UniqueIni _,_ | A.OptIni _,_ ->
- failwith "not handling Opt/Unique on initialisers"
-
- | _, (B.InitIndexOld (_, _), _) -> fail
- | _, (B.InitFieldOld (_, _), _) -> fail
-
- | _, ((B.InitDesignators (_, _)|B.InitList _|B.InitExpr _), _)
- -> fail
-
-
-
-
-
-
-and initialisers = fun ias (ibs, iicomma) ->
- let ias_unsplit = unsplit_icomma ias in
- let ibs_split = resplit_initialiser ibs iicomma in
-
- let f =
- if need_unordered_initialisers ibs
- then initialisers_unordered2
- else initialisers_ordered2
- in
- f ias_unsplit ibs_split >>=
- (fun ias_unsplit ibs_split ->
- return (
- split_icomma ias_unsplit,
- unsplit_initialiser ibs_split
- )
- )
-
-(* todo: one day julia will reput a IDots *)
-and initialisers_ordered2 = fun ias ibs ->
- match ias, ibs with
- | [], [] -> return ([], [])
- | (x, xcomma)::xs, (y, commay)::ys ->
- (match A.unwrap xcomma with
- | A.IComma commax ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- initialisers_ordered2 xs ys >>= (fun xs ys ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
- (y, commay)::ys
- )
- )))
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- | _ -> fail
-
-
-
-and initialisers_unordered2 = fun ias ibs ->
-
- match ias, ibs with
- | [], ys -> return ([], ys)
- | (x,xcomma)::xs, ys ->
-
- let permut = Common.uncons_permut_lazy ys in
- permut +> List.fold_left (fun acc ((e, pos), rest) ->
- acc >||>
- (
- (match A.unwrap xcomma, e with
- | A.IComma commax, (y, commay) ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma),
- (y, commay))
- )
- )
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- >>= (fun x e ->
- let rest = Lazy.force rest in
- initialisers_unordered2 xs rest >>= (fun xs rest ->
- return (
- x::xs,
- Common.insert_elem_pos (e, pos) rest
- ))))
- ) fail
-
-
-(* ------------------------------------------------------------------------- *)
-and (struct_fields: (A.declaration list, B.field list) matcher) =
- fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Ddots (mcode, optwhen), ys ->
- if optwhen <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
-
- X.distrf_struct_fields (dots2metavar mcode) startxs
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- struct_fields eas endxs >>= (fun eas endxs ->
- return (
- (A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
- | _unwrapx, eb::ebs ->
- struct_field ea eb >>= (fun ea eb ->
- struct_fields eas ebs >>= (fun eas ebs ->
- return (ea::eas, eb::ebs)
- ))
-
- | _unwrapx, [] -> fail
- )
-
-and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
- let (xfield, iifield) = fb in
-
- match xfield with
- | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
-
- let iiptvirgb = tuple_of_list1 iiptvirg in
-
- (match onefield_multivars with
- | [] -> raise Impossible
- | [onevar,iivirg] ->
- assert (null iivirg);
- (match onevar with
- | B.BitField (sopt, typb, expr), ii ->
- pr2_once "warning: bitfield not handled by ast_cocci";
- fail
- | B.Simple (None, typb), ii ->
- pr2_once "warning: unamed struct field not handled by ast_cocci";
- fail
- | B.Simple (Some idb, typb), ii ->
- let (iidb) = tuple_of_list1 ii in
-
- (* build a declaration from a struct field *)
- let allminus = false in
- let iisto = [] in
- let stob = B.NoSto, false in
- let fake_var =
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = Ast_c.NotLocalDecl;
- B.v_attr = Ast_c.noattr;
- },
- iivirg)
- in
- onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
- (fun fa (var,iiptvirgb,iisto) ->
-
- match fake_var with
- | ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- }, iivirg) ->
- let onevar = B.Simple (Some idb, typb), [iidb] in
-
- return (
- (fa),
- ((B.DeclarationField
- (B.FieldDeclList ([onevar, iivirg], [iiptvirgb]))),
- iifield)
- )
- | _ -> raise Impossible
- )
- )
-
- | x::y::xs ->
- pr2_once "PB: More that one variable in decl. Have to split";
- fail
- )
- | B.EmptyField ->
- let _iiptvirgb = tuple_of_list1 iifield in
- fail
-
- | B.MacroStructDeclTodo -> fail
- | B.CppDirectiveStruct directive -> fail
- | B.IfdefStruct directive -> fail
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (fullType: (A.fullType, Ast_c.fullType) matcher) =
- fun typa typb ->
- X.optional_qualifier_flag (fun optional_qualifier ->
- X.all_bound (A.get_inherited typa) >&&>
- match A.unwrap typa, typb with
- | A.Type(cv,ty1), ((qu,il),ty2) ->
-
- if qu.B.const && qu.B.volatile
- then
- pr2_once
- ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
-
- (* Drop out the const/volatile part that has been matched.
- * This is because a SP can contain const T v; in which case
- * later in match_t_t when we encounter a T, we must not add in
- * the environment the whole type.
- *)
-
-
- (match cv with
- (* "iso-by-absence" *)
- | None ->
- let do_stuff () =
- fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
- return (
- (A.Type(None, ty1)) +> A.rewrap typa,
- fullty2
- ))
- in
- (match optional_qualifier, qu.B.const || qu.B.volatile with
- | false, false -> do_stuff ()
- | false, true -> fail
- | true, false -> do_stuff ()
- | true, true ->
- if !Flag.show_misc
- then pr2_once "USING optional_qualifier builtin isomorphism";
- do_stuff()
- )
-
-
- | Some x ->
- (* todo: can be __const__ ? can be const & volatile so
- * should filter instead ?
- *)
- (match term x, il with
- | A.Const, [i1] when qu.B.const ->
-
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | A.Volatile, [i1] when qu.B.volatile ->
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | _ -> fail
- )
- )
-
- | A.DisjType typas, typb ->
- typas +>
- List.fold_left (fun acc typa -> acc >|+|> (fullType typa typb)) fail
-
- | A.OptType(_), _ | A.UniqueType(_), _
- -> failwith "not handling Opt/Unique on type"
- )
-
-
-(*
- * Why not (A.typeC, Ast_c.typeC) matcher ?
- * because when there is MetaType, we want that T record the whole type,
- * including the qualifier, and so this type (and the new_il function in
- * preceding function).
-*)
-
-and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
- fun ta tb ->
- X.all_bound (A.get_inherited ta) >&&>
- match A.unwrap ta, tb with
-
- (* cas general *)
- | A.MetaType(ida,keep, inherited), typb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
- X.distrf_type ida typb >>= (fun ida typb ->
- return (
- A.MetaType(ida,keep, inherited) +> A.rewrap ta,
- typb
- ))
- )
- | unwrap, (qub, typb) ->
- typeC ta typb >>= (fun ta typb ->
- return (ta, (qub, typb))
- )
-
-and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda =
- (* In ii there is a list, sometimes of length 1 or 2 or 3.
- * And even if in baseb we have a Signed Int, that does not mean
- * that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
- * something :( So for the moment when there is signed in cocci,
- * we force that there is a signed in c too (done in pattern.ml).
- *)
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
-
- (* handle some iso on type ? (cf complex C rule for possible implicit
- casting) *)
- match basea, baseb with
- | A.VoidType, B.Void
- | A.FloatType, B.FloatType (B.CFloat)
- | A.DoubleType, B.FloatType (B.CDouble) ->
- assert (signaopt = None);
- let stringa = tuple_of_list1 stringsa in
- let (ibaseb) = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType baseb, [ibaseb])
- ))
-
- | A.CharType, B.IntType B.CChar when signaopt = None ->
- let stringa = tuple_of_list1 stringsa in
- let ibaseb = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (B.IntType B.CChar), [ibaseb])
- ))
-
- | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
- let stringa = tuple_of_list1 stringsa in
- let ibaseb = tuple_of_list1 iibaseb in
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
-
- | A.ShortType, B.IntType (B.Si (_, B.CShort))
- | A.IntType, B.IntType (B.Si (_, B.CInt))
- | A.LongType, B.IntType (B.Si (_, B.CLong)) ->
- let stringa = tuple_of_list1 stringsa in
- (match iibaseb with
- | [] ->
- (* iso-by-presence ? *)
- (* when unsigned int in SP, allow have just unsigned in C ? *)
- if mcode_contain_plus (mcodekind stringa)
- then fail
- else
-
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [])
- ))
-
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
- | _ -> raise Impossible
-
- )
-
-
- | A.LongLongType, B.IntType (B.Si (_, B.CLongLong)) ->
- let (string1a,string2a) = tuple_of_list2 stringsa in
- (match iibaseb with
- [ibase1b;ibase2b] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf string1a ibase1b >>= (fun base1a ibase1b ->
- tokenf string2a ibase2b >>= (fun base2a ibase2b ->
- return (
- (rebuilda ([base1a;base2a], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibase1b;ibase2b])
- ))))
- | [] -> fail (* should something be done in this case? *)
- | _ -> raise Impossible)
-
-
- | _, B.FloatType B.CLongDouble
- ->
- pr2_once
- "warning: long double not handled by ast_cocci";
- fail
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda =
- (* In ii there is a list, sometimes of length 1 or 2 or 3.
- * And even if in baseb we have a Signed Int, that does not mean
- * that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
- * something :( So for the moment when there is signed in cocci,
- * we force that there is a signed in c too (done in pattern.ml).
- *)
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
- let match_to_type rebaseb =
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- let ibaseb = tuple_of_list1 iibaseb in
- let fta = A.rewrap basea (A.Type(None,basea)) in
- let ftb = Ast_c.nQ,(B.BaseType (rebaseb), [ibaseb]) in
- fullType fta ftb >>= (fun fta (_,tb) ->
- (match A.unwrap fta,tb with
- A.Type(_,basea), (B.BaseType baseb, ii) ->
- let ibaseb = tuple_of_list1 ii in
- return (
- (rebuilda (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )
- | _ -> failwith "not possible"))) in
-
- (* handle some iso on type ? (cf complex C rule for possible implicit
- casting) *)
- match baseb with
- | B.IntType (B.Si (_sign, B.CChar2)) ->
- match_to_type (B.IntType B.CChar)
-
- | B.IntType (B.Si (_, ty)) ->
- (match iibaseb with
- | [] -> fail (* metavariable has to match something *)
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
- | _ -> raise Impossible
-
- )
-
- | (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and (typeC: (A.typeC, Ast_c.typeC) matcher) =
- fun ta tb ->
- match A.unwrap ta, tb with
- | A.BaseType (basea,stringsa), (B.BaseType baseb, ii) ->
- simulate_signed ta basea stringsa None tb baseb ii
- (function (stringsa, signaopt) -> A.BaseType (basea,stringsa))
- | A.SignedT (signaopt, Some basea), (B.BaseType baseb, ii) ->
- (match A.unwrap basea with
- A.BaseType (basea1,strings1) ->
- simulate_signed ta basea1 strings1 (Some signaopt) tb baseb ii
- (function (strings1, Some signaopt) ->
- A.SignedT
- (signaopt,
- Some (A.rewrap basea (A.BaseType (basea1,strings1))))
- | _ -> failwith "not possible")
- | A.MetaType(ida,keep,inherited) ->
- simulate_signed_meta ta basea (Some signaopt) tb baseb ii
- (function (basea, Some signaopt) ->
- A.SignedT(signaopt,Some basea)
- | _ -> failwith "not possible")
- | _ -> failwith "not possible")
- | A.SignedT (signa,None), (B.BaseType baseb, ii) ->
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
- (match iibaseb, baseb with
- | [], B.IntType (B.Si (_sign, B.CInt)) ->
- sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
- match signaopt with
- | None -> raise Impossible
- | Some signa ->
- return (
- (A.SignedT (signa,None)) +> A.rewrap ta,
- (B.BaseType baseb, iisignbopt)
- )
- )
- | _ -> fail
- )
-
-
-
- (* todo? iso with array *)
- | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
- let (ibmult) = tuple_of_list1 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf iamult ibmult >>= (fun iamult ibmult ->
- return (
- (A.Pointer (typa, iamult)) +> A.rewrap ta,
- (B.Pointer typb, [ibmult])
- )))
-
- | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
-
- let (lpb, rpb) = tuple_of_list2 ii in
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- return (
- (A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa) +> A.rewrap ta,
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), [lpb;rpb])
- )
- )))))
-
-
-
-
-
- | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
- (B.ParenType t1, ii) ->
- let (lp1b, rp1b) = tuple_of_list2 ii in
- let (qu1b, t1b) = t1 in
- (match t1b with
- | B.Pointer t2, ii ->
- let (starb) = tuple_of_list1 ii in
- let (qu2b, t2b) = t2 in
- (match t2b with
- | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
- let (lp2b, rp2b) = tuple_of_list2 ii in
-
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
-
- fullType tya tyb >>= (fun tya tyb ->
- tokenf lp1a lp1b >>= (fun lp1a lp1b ->
- tokenf rp1a rp1b >>= (fun rp1a rp1b ->
- tokenf lp2a lp2b >>= (fun lp2a lp2b ->
- tokenf rp2a rp2b >>= (fun rp2a rp2b ->
- tokenf stara starb >>= (fun stara starb ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
-
- let t2 =
- (qu2b,
- (B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
- [lp2b;rp2b]))
- in
- let t1 =
- (qu1b,
- (B.Pointer t2, [starb]))
- in
-
- return (
- (A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
- +> A.rewrap ta,
- (B.ParenType t1, [lp1b;rp1b])
- )
- )))))))
-
-
-
- | _ -> fail
- )
- | _ -> fail
- )
-
-
-
- (* todo: handle the iso on optionnal size specifification ? *)
- | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- option expression eaopt ebopt >>= (fun eaopt ebopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- (A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
- (B.Array (ebopt, typb), [ib1;ib2])
- )))))
-
-
- (* todo: could also match a Struct that has provided a name *)
- (* This is for the case where the SmPL code contains "struct x", without
- a definition. In this case, the name field is always present.
- This case is also called from the case for A.StructUnionDef when
- a name is present in the C code. *)
- | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
- (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
- let (ib1, ib2) = tuple_of_list2 ii in
- if equal_structUnion (term sua) sub
- then
- ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
- tokenf sua ib1 >>= (fun sua ib1 ->
- return (
- (A.StructUnionName (sua, Some sa)) +> A.rewrap ta,
- (B.StructUnionName (sub, sb), [ib1;ib2])
- )))
- else fail
-
-
- | A.StructUnionDef(ty, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
-
- let (ii_sub_sb, lbb, rbb) =
- match ii with
- [iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
- | [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
- | _ -> failwith "list of length 3 or 4 expected" in
-
- let process_type =
- match (sbopt,ii_sub_sb) with
- (None,Common.Left iisub) ->
- (* the following doesn't reconstruct the complete SP code, just
- the part that matched *)
- let rec loop s =
- match A.unwrap s with
- A.Type(None,ty) ->
- (match A.unwrap ty with
- A.StructUnionName(sua, None) ->
- tokenf sua iisub >>= (fun sua iisub ->
- let ty =
- A.Type(None,
- A.StructUnionName(sua, None) +> A.rewrap ty)
- +> A.rewrap s in
- return (ty,[iisub]))
- | _ -> fail)
- | A.DisjType(disjs) ->
- disjs +>
- List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
- | _ -> fail in
- loop ty
-
- | (Some sb,Common.Right (iisub,iisb)) ->
-
- (* build a StructUnionName from a StructUnion *)
- let fake_su = B.nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) in
-
- fullType ty fake_su >>= (fun ty fake_su ->
- match fake_su with
- | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
- return (ty, [iisub; iisb])
- | _ -> raise Impossible)
- | _ -> fail in
-
- process_type
- >>= (fun ty ii_sub_sb ->
-
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
- struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
- let declsa = redots declsa undeclsa in
-
- return (
- (A.StructUnionDef(ty, lba, declsa, rba)) +> A.rewrap ta,
- (B.StructUnion (sub, sbopt, declsb),ii_sub_sb@[lbb;rbb])
- )))))
-
-
- (* todo? handle isomorphisms ? because Unsigned Int can be match on a
- * uint in the C code. But some CEs consists in renaming some types,
- * so we don't want apply isomorphisms every time.
- *)
- | A.TypeName sa, (B.TypeName (sb,typb), ii) ->
- let (isb) = tuple_of_list1 ii in
- if (term sa) =$= sb
- then
- tokenf sa isb >>= (fun sa isb ->
- return (
- (A.TypeName sa) +> A.rewrap ta,
- (B.TypeName (sb,typb), [isb])
- ))
- else fail
-
- | _, (B.TypeOfExpr e, ii) -> fail
- | _, (B.TypeOfType e, ii) -> fail
-
- | _, (B.ParenType e, ii) -> fail (* todo ?*)
- | A.EnumName(en,namea), (B.EnumName nameb, ii) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
- tokenf en ib1 >>= (fun en ib1 ->
- return (
- (A.EnumName (en, namea)) +> A.rewrap ta,
- (B.EnumName nameb, [ib1;ib2])
- )))
-
- | _, (B.Enum _, _) -> fail (* todo cocci ?*)
-
- | _,
- ((B.TypeName (_, _) | B.StructUnionName (_, _) | B.EnumName _ |
- B.StructUnion (_, _, _) |
- B.FunctionType _ | B.Array (_, _) | B.Pointer _ |
- B.BaseType _),
- _)
- -> fail
-
-
-(* todo: iso on sign, if not mentioned then free. tochange?
- * but that require to know if signed int because explicit
- * signed int, or because implicit signed int.
- *)
-
-and sign signa signb =
- match signa, signb with
- | None, None -> return (None, [])
- | Some signa, Some (signb, ib) ->
- if equal_sign (term signa) signb
- then tokenf signa ib >>= (fun signa ib ->
- return (Some signa, [ib])
- )
- else fail
- | _, _ -> fail
-
-
-and minusize_list iixs =
- iixs +> List.fold_left (fun acc ii ->
- acc >>= (fun xs ys ->
- tokenf minusizer ii >>= (fun minus ii ->
- return (minus::xs, ii::ys)
- ))) (return ([],[]))
- >>= (fun _xsminys ys ->
- return ((), List.rev ys)
- )
-
-and storage_optional_allminus allminus stoa (stob, iistob) =
- (* "iso-by-absence" for storage, and return type. *)
- X.optional_storage_flag (fun optional_storage ->
- match stoa, stob with
- | None, (stobis, inline) ->
- let do_minus () =
- if allminus
- then
- minusize_list iistob >>= (fun () iistob ->
- return (None, (stob, iistob))
- )
- else return (None, (stob, iistob))
- in
-
- (match optional_storage, stobis with
- | false, B.NoSto -> do_minus ()
- | false, _ -> fail
- | true, B.NoSto -> do_minus ()
- | true, _ ->
- if !Flag.show_misc
- then pr2_once "USING optional_storage builtin isomorphism";
- do_minus()
- )
-
- | Some x, ((stobis, inline)) ->
- if equal_storage (term x) stobis
- then
- match iistob with
- | [i1] ->
- tokenf x i1 >>= (fun x i1 ->
- return (Some x, ((stobis, inline), [i1]))
- )
- (* or if have inline ? have to do a split_storage_inline a la
- * split_signb_baseb_ii *)
- | _ -> raise Impossible
- else fail
- )
-
-
-
-
-
-and fullType_optional_allminus allminus tya retb =
- match tya with
- | None ->
- if allminus
- then
- X.distrf_type minusizer retb >>= (fun _x retb ->
- return (None, retb)
- )
-
- else return (None, retb)
- | Some tya ->
- fullType tya retb >>= (fun tya retb ->
- return (Some tya, retb)
- )
-
-
-
-(*---------------------------------------------------------------------------*)
-
-and compatible_base_type a signa b =
- let ok = return ((),()) in
-
- match a, b with
- | Type_cocci.VoidType, B.Void ->
- assert (signa = None);
- ok
- | Type_cocci.CharType, B.IntType B.CChar when signa = None ->
- ok
- | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb
- | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
- compatible_sign signa signb
- | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
- compatible_sign signa signb
- | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
- compatible_sign signa signb
- | _, B.IntType (B.Si (signb, B.CLongLong)) ->
- pr2_once "no longlong in cocci";
- fail
- | Type_cocci.FloatType, B.FloatType B.CFloat ->
- assert (signa = None);
- ok
- | Type_cocci.DoubleType, B.FloatType B.CDouble ->
- assert (signa = None);
- ok
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
- | Type_cocci.BoolType, _ -> failwith "no booltype in C"
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and compatible_base_type_meta a signa qua b ii local =
- match a, b with
- | Type_cocci.MetaType(ida,keep,inherited),
- B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb >>= fun _ _ ->
- let newb = ((qua, (B.BaseType (B.IntType B.CChar),ii)),local) in
- compatible_type a newb
- | Type_cocci.MetaType(ida,keep,inherited), B.IntType (B.Si (signb, ty)) ->
- compatible_sign signa signb >>= fun _ _ ->
- let newb =
- ((qua, (B.BaseType (B.IntType (B.Si (B.Signed, ty))),ii)),local) in
- compatible_type a newb
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-
-and compatible_type a (b,local) =
- let ok = return ((),()) in
-
- let rec loop = function
- | Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
- compatible_base_type a None b
-
- | Type_cocci.SignedT (signa,None), (qua, (B.BaseType b,ii)) ->
- compatible_base_type Type_cocci.IntType (Some signa) b
-
- | Type_cocci.SignedT (signa,Some ty), (qua, (B.BaseType b,ii)) ->
- (match ty with
- Type_cocci.BaseType ty ->
- compatible_base_type ty (Some signa) b
- | Type_cocci.MetaType(ida,keep,inherited) ->
- compatible_base_type_meta ty (Some signa) qua b ii local
- | _ -> failwith "not possible")
-
- | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
- loop (a,b)
- | Type_cocci.FunctionPointer a, _ ->
- failwith
- "TODO: function pointer type doesn't store enough information to determine compatability"
- | Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
- (* no size info for cocci *)
- loop (a,b)
- | Type_cocci.StructUnionName (sua, _, sa),
- (qub, (B.StructUnionName (sub, sb),ii)) ->
- if equal_structUnion_type_cocci sua sub && sa = sb
- then ok
- else fail
- | Type_cocci.EnumName (_, sa),
- (qub, (B.EnumName (sb),ii)) ->
- if sa = sb
- then ok
- else fail
- | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
- if sa = sb
- then ok
- else fail
-
- | Type_cocci.ConstVol (qua, a), (qub, b) ->
- if (fst qub).B.const && (fst qub).B.volatile
- then
- begin
- pr2_once ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
- fail
- end
- else
- if
- (match qua with
- | Type_cocci.Const -> (fst qub).B.const
- | Type_cocci.Volatile -> (fst qub).B.volatile
- )
- then loop (a,(Ast_c.nQ, b))
- else fail
-
- | Type_cocci.MetaType (ida,keep,inherited), typb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (A.make_mcode ida, B.MetaTypeVal typb, max_min)
- (fun () -> ok
- )
-
- (* subtil: must be after the MetaType case *)
- | a, (qub, (B.TypeName (sb,Some b), ii)) ->
- (* kind of typedef iso *)
- loop (a,b)
-
-
-
-
-
- (* for metavariables of type expression *^* *)
- | Type_cocci.Unknown , _ -> ok
-
- | (_,
- (_,
- ((
- B.TypeOfType _|B.TypeOfExpr _|B.ParenType _|
- B.EnumName _|B.StructUnion (_, _, _)|B.Enum (_, _)
- ),
- _))) -> fail
-
- | (_,
- (_,
- ((
- B.StructUnionName (_, _)|
- B.FunctionType _|
- B.Array (_, _)|B.Pointer _|B.TypeName _|
- B.BaseType _
- ),
- _))) -> fail
-
-
- in
- loop (a,b)
-
-and compatible_sign signa signb =
- let ok = return ((),()) in
- match signa, signb with
- | None, B.Signed
- | Some Type_cocci.Signed, B.Signed
- | Some Type_cocci.Unsigned, B.UnSigned
- -> ok
- | _ -> fail
-
-
-and equal_structUnion_type_cocci a b =
- match a, b with
- | Type_cocci.Struct, B.Struct -> true
- | Type_cocci.Union, B.Union -> true
- | _, (B.Struct | B.Union) -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-and inc_file (a, before_after) (b, h_rel_pos) =
-
- let rec aux_inc (ass, bss) passed =
- match ass, bss with
- | [], [] -> true
- | [A.IncDots], _ ->
- let passed = List.rev passed in
-
- (match before_after, !h_rel_pos with
- | IncludeNothing, _ -> true
- | IncludeMcodeBefore, Some x ->
- List.mem passed (x.Ast_c.first_of)
-
- | IncludeMcodeAfter, Some x ->
- List.mem passed (x.Ast_c.last_of)
-
- (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
- | _, None -> false
- )
-
- | (A.IncPath x)::xs, y::ys -> x = y && aux_inc (xs, ys) (x::passed)
- | _ -> failwith "IncDots not in last place or other pb"
-
- in
-
- match a, b with
- | A.Local ass, B.Local bss ->
- aux_inc (ass, bss) []
- | A.NonLocal ass, B.NonLocal bss ->
- aux_inc (ass, bss) []
- | _ -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-
-and (define_params: sequence ->
- (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- define_paramsbis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-(* todo? facto code with argument and parameters ? *)
-and define_paramsbis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.DPdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_define_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- define_paramsbis eas endxs >>= (fun eas endxs ->
- return (
- (A.DPdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.DPComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DPComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.DPComma ia1, ebs ->
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else
- (define_paramsbis eas ebs) (* try optional comma trick *)
-
- | (A.OptDParam _ | A.UniqueDParam _), _ ->
- failwith "handling Opt/Unique for define parameters"
-
- | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
- | A.DParam ida, (Left (idb, ii))::ebs ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DParam ida)+> A.rewrap ea :: eas,
- (Left (idb, [ib1]))::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-(*****************************************************************************)
-(* Entry points *)
-(*****************************************************************************)
-
-(* no global solution for positions here, because for a statement metavariable
-we want a MetaStmtVal, and for the others, it's not clear what we want *)
-
-let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
- fun re node ->
- let rewrap x =
- x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
- in
- X.all_bound (A.get_inherited re) >&&>
-
- rewrap (
- match A.unwrap re, F.unwrap node with
-
- (* note: the order of the clauses is important. *)
-
- | _, F.Enter | _, F.Exit | _, F.ErrorExit -> fail2()
-
- (* the metaRuleElem contains just '-' information. We dont need to add
- * stuff in the environment. If we need stuff in environment, because
- * there is a + S somewhere, then this will be done via MetaStmt, not
- * via MetaRuleElem.
- * Can match TrueNode/FalseNode/... so must be placed before those cases.
- *)
-
- | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
- let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
- (match unwrap_node with
- | F.CaseNode _
- | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
- | F.InLoopNode ->
- if X.mode = PatternMode
- then return default
- else
- if mcode_contain_plus (mcodekind mcode)
- then failwith "try add stuff on fake node"
- (* minusize or contextize a fake node is ok *)
- else return default
-
- | F.EndStatement None ->
- if X.mode = PatternMode then return default
- else
- (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
- if mcode_contain_plus (mcodekind mcode)
- then
- let fake_info = Ast_c.fakeInfo() in
- distrf distrf_node (mcodekind mcode)
- (F.EndStatement (Some fake_info))
- else return unwrap_node
- *)
- raise Todo
-
- | F.EndStatement (Some i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.MetaRuleElem (mcode,keep, inherited),
- F.EndStatement (Some i1)
- ))
-
- | F.FunHeader _ ->
- if X.mode = PatternMode then return default
- else failwith "a MetaRuleElem can't transform a headfunc"
- | _n ->
- if X.mode = PatternMode then return default
- else
- X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
- return (
- A.MetaRuleElem(mcode,keep, inherited),
- F.unwrap node
- ))
- )
-
-
- (* rene cant have found that a state containing a fake/exit/... should be
- * transformed
- * TODO: and F.Fake ?
- *)
- | _, F.EndStatement _ | _, F.CaseNode _
- | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
- | _, F.InLoopNode
- -> fail2()
-
- (* really ? diff between pattern.ml and transformation.ml *)
- | _, F.Fake -> fail2()
-
-
- (* cas general: a Meta can match everything. It matches only
- * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
- * So can't have been called in transform.
- *)
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
-
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
- (* todo: should not happen in transform mode *)
-
- (match Control_flow_c.extract_fullstatement node with
- | Some stb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_stmt stb) in
- X.envf keep inherited (ida, Ast_c.MetaStmtVal stb, max_min)
- (fun () ->
- (* no need tag ida, we can't be called in transform-mode *)
- return (
- A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
- unwrap_node
- )
- )
- | None -> fail
- )
-
- (* not me?: *)
- | A.MetaStmtList _, _ ->
- failwith "not handling MetaStmtList"
-
- | A.TopExp ea, F.DefineExpr eb ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.TopExp ea,
- F.DefineExpr eb
- ))
-
- | A.TopExp ea, F.DefineType eb ->
- (match A.unwrap ea with
- A.TypeExp(ft) ->
- fullType ft eb >>= (fun ft eb ->
- return (
- A.TopExp (A.rewrap ea (A.TypeExp(ft))),
- F.DefineType eb
- ))
- | _ -> fail)
-
-
-
- (* It is important to put this case before the one that fails because
- * of the lack of the counter part of a C construct in SmPL (for instance
- * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
- * yet certain constructs, those constructs may contain expression
- * that we still want and can transform.
- *)
-
- | A.Exp exp, nodeb ->
-
- (* kind of iso, initialisation vs affectation *)
- let node =
- match A.unwrap exp, nodeb with
- | A.Assignment (ea, op, eb, true), F.Decl decl ->
- initialisation_to_affectation decl +> F.rewrap node
- | _ -> node
- in
-
-
- (* Now keep fullstatement inside the control flow node,
- * so that can then get in a MetaStmtVar the fullstatement to later
- * pp back when the S is in a +. But that means that
- * Exp will match an Ifnode even if there is no such exp
- * inside the condition of the Ifnode (because the exp may
- * be deeper, in the then branch). So have to not visit
- * all inside a node anymore.
- *
- * update: j'ai choisi d'accrocher au noeud du CFG Ã la
- * fois le fullstatement et le partialstatement et appeler le
- * visiteur que sur le partialstatement.
- *)
- let expfn =
- match Ast_cocci.get_pos re with
- | None -> expression
- | Some pos ->
- (fun ea eb ->
- let (max,min) =
- Lib_parsing_c.max_min_by_pos (Lib_parsing_c.ii_of_expr eb) in
- let keep = Type_cocci.Unitary in
- let inherited = false in
- let max_min _ = failwith "no pos" in
- X.envf keep inherited (pos, B.MetaPosVal (min,max), max_min)
- (fun () ->
- expression ea eb
- )
- )
- in
- X.cocciExp expfn exp node >>= (fun exp node ->
- return (
- A.Exp exp,
- F.unwrap node
- )
- )
-
- | A.Ty ty, nodeb ->
- X.cocciTy fullType ty node >>= (fun ty node ->
- return (
- A.Ty ty,
- F.unwrap node
- )
- )
-
- | A.TopInit init, nodeb ->
- X.cocciInit initialiser init node >>= (fun init node ->
- return (
- A.TopInit init,
- F.unwrap node
- )
- )
-
-
- | A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
- F.FunHeader ({B.f_name = idb;
- f_type = (retb, (paramsb, (isvaargs, iidotsb)));
- f_storage = stob;
- f_attr = attrs;
- f_body = body;
- f_old_c_style = oldstyle;
- }, ii) ->
- assert (null body);
-
- if oldstyle <> None
- then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
-
-
- (* fninfoa records the order in which the SP specified the various
- information, but this isn't taken into account in the matching.
- Could this be a problem for transformation? *)
- let stoa =
- match
- List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
- with [A.FStorage(s)] -> Some s | _ -> None in
- let tya =
- match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
- with [A.FType(t)] -> Some t | _ -> None in
-
- (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
- with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
-
- (match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
- with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
-
- (match ii with
- | iidb::ioparenb::icparenb::iifakestart::iistob ->
-
- (* maybe important to put ident as the first tokens to transform.
- * It's related to transform_proto. So don't change order
- * between the >>=.
- *)
- ident LocalFunction ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- tokenf oparen ioparenb >>= (fun oparen ioparenb ->
- tokenf cparen icparenb >>= (fun cparen icparenb ->
- parameters (seqstyle paramsa)
- (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- storage_optional_allminus allminus
- stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
- (
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
- if allminus
- then minusize_list iidotsb
- else return ((),iidotsb)
- ) >>= (fun () iidotsb ->
-
- fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
-
- let fninfoa =
- (match stoa with Some st -> [A.FStorage st] | None -> []) ++
- (match tya with Some t -> [A.FType t] | None -> [])
-
- in
-
- return (
- A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
- paramsa,cparen),
- F.FunHeader ({B.f_name = idb;
- f_type = (retb, (paramsb, (isvaargs, iidotsb)));
- f_storage = stob;
- f_attr = attrs;
- f_body = body;
- f_old_c_style = oldstyle; (* TODO *)
- },
- iidb::ioparenb::icparenb::iifakestart::iistob)
- )
- ))))))))
- | _ -> raise Impossible
- )
-
-
-
-
-
-
- | A.Decl (mckstart,allminus,decla), F.Decl declb ->
- declaration (mckstart,allminus,decla) declb >>=
- (fun (mckstart,allminus,decla) declb ->
- return (
- A.Decl (mckstart,allminus,decla),
- F.Decl declb
- ))
-
-
- | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.SeqStart mcode,
- F.SeqStart (st, level, i1)
- ))
-
- | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.SeqEnd mcode,
- F.SeqEnd (level, i1)
- ))
-
- | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- A.ExprStatement (ea, ia1),
- F.ExprStatement (st, (Some eb, [ib1]))
- )
- ))
-
-
- | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- A.IfHeader (ia1, ia2, ea, ia3),
- F.IfHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | A.Else ia, F.Else ib ->
- tokenf ia ib >>= (fun ia ib ->
- return (A.Else ia, F.Else ib)
- )
-
- | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- A.WhileHeader (ia1, ia2, ea, ia3),
- F.WhileHeader (st, (eb, [ib1;ib2;ib3]))
- )))))
-
- | A.DoHeader ia, F.DoHeader (st, ib) ->
- tokenf ia ib >>= (fun ia ib ->
- return (
- A.DoHeader ia,
- F.DoHeader (st, ib)
- ))
- | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
- let (ib1, ib2, ib3, ib4) = tuple_of_list4 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- return (
- A.WhileTail (ia1,ia2,ea,ia3,ia4),
- F.DoWhileTail (eb, [ib1;ib2;ib3;ib4])
- ))))))
- | A.IteratorHeader (ia1, ia2, eas, ia3), F.MacroIterHeader (st, ((s,ebs),ii))
- ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
-
- ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- A.IteratorHeader (ia1, ia2, eas, ia3),
- F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
- )))))
-
-
-
- | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,ib3s), (eb2opt,ib4s), (eb3opt,ib4vide)), ii))
- ->
- assert (null ib4vide);
- let (ib1, ib2, ib5) = tuple_of_list3 ii in
- let ib3 = tuple_of_list1 ib3s in
- let ib4 = tuple_of_list1 ib4s in
-
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- tokenf ia5 ib5 >>= (fun ia5 ib5 ->
- option expression ea1opt eb1opt >>= (fun ea1opt eb1opt ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- option expression ea3opt eb3opt >>= (fun ea3opt eb3opt ->
- return (
- A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,[ib3]), (eb2opt,[ib4]), (eb3opt,[])),
- [ib1;ib2;ib5]))
-
- )))))))))
-
-
- | A.SwitchHeader(ia1,ia2,ea,ia3), F.SwitchHeader (st, (eb,ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.SwitchHeader(ia1,ia2,ea,ia3),
- F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Break (ia1, ia2),
- F.Break (st, ((),[ib1;ib2]))
- )))
-
- | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Continue (ia1, ia2),
- F.Continue (st, ((),[ib1;ib2]))
- )))
-
- | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Return (ia1, ia2),
- F.Return (st, ((),[ib1;ib2]))
- )))
-
- | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.ReturnExpr (ia1, ea, ia2),
- F.ReturnExpr (st, (eb, [ib1;ib2]))
- ))))
-
-
-
- | A.Include(incla,filea),
- F.Include {B.i_include = (fileb, ii);
- B.i_rel_pos = h_rel_pos;
- B.i_is_in_ifdef = inifdef;
- B.i_content = copt;
- } ->
- assert (copt = None);
-
- let include_requirment =
- match mcodekind incla, mcodekind filea with
- | A.CONTEXT (_, A.BEFORE _), _ ->
- IncludeMcodeBefore
- | _, A.CONTEXT (_, A.AFTER _) ->
- IncludeMcodeAfter
- | _ ->
- IncludeNothing
- in
-
- let (inclb, iifileb) = tuple_of_list2 ii in
- if inc_file (term filea, include_requirment) (fileb, h_rel_pos)
- then
- tokenf incla inclb >>= (fun incla inclb ->
- tokenf filea iifileb >>= (fun filea iifileb ->
- return (
- A.Include(incla, filea),
- F.Include {B.i_include = (fileb, [inclb;iifileb]);
- B.i_rel_pos = h_rel_pos;
- B.i_is_in_ifdef = inifdef;
- B.i_content = copt;
- }
- )))
- else fail
-
-
-
- | A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
- let (defineb, iidb, ieol) = tuple_of_list3 ii in
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- tokenf definea defineb >>= (fun definea defineb ->
- (match A.unwrap params, defkind with
- | A.NoParams, B.DefineVar ->
- return (
- A.NoParams +> A.rewrap params,
- B.DefineVar
- )
- | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
- let (lpb, rpb) = tuple_of_list2 ii in
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
-
- define_params (seqstyle eas) (A.undots eas) ebs >>=
- (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- A.DParams (lpa,eas,rpa) +> A.rewrap params,
- B.DefineFunc (ebs,[lpb;rpb])
- )
- )))
- | _ -> fail
- ) >>= (fun params defkind ->
- return (
- A.DefineHeader (definea, ida, params),
- F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
- ))
- ))
-
-
- | A.Default(def,colon), F.Default (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf def ib1 >>= (fun def ib1 ->
- tokenf colon ib2 >>= (fun colon ib2 ->
- return (
- A.Default(def,colon),
- F.Default (st, ((),[ib1;ib2]))
- )))
-
-
-
- | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf case ib1 >>= (fun case ib1 ->
- expression ea eb >>= (fun ea eb ->
- tokenf colon ib2 >>= (fun colon ib2 ->
- return (
- A.Case(case,ea,colon),
- F.Case (st, (eb,[ib1;ib2]))
- ))))
-
- (* only occurs in the predicates generated by asttomember *)
- | A.DisjRuleElem eas, _ ->
- (eas +>
- List.fold_left (fun acc ea -> acc >|+|> (rule_elem_node ea node)) fail)
- >>= (fun ea eb -> return (A.unwrap ea,F.unwrap eb))
-
- | _, F.ExprStatement (_, (None, ii)) -> fail (* happen ? *)
-
- | A.Label(id,dd), F.Label (st,(s,ii)) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- let (string_of_id,rebuild) =
- match A.unwrap id with
- A.Id(s) -> (s,function s -> A.rewrap id (A.Id(s)))
- | _ -> failwith "labels with metavariables not supported" in
- if (term string_of_id) =$= s
- then
- tokenf string_of_id ib1 >>= (fun string_of_id ib1 ->
- tokenf dd ib2 >>= (fun dd ib2 ->
- return (
- A.Label(rebuild string_of_id,dd),
- F.Label (st,(s,[ib1;ib2]))
- )))
- else fail
-
- | A.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- tokenf goto ib1 >>= (fun goto ib1 ->
- ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
- tokenf sem ib3 >>= (fun sem ib3 ->
- return(
- A.Goto(goto,id,sem),
- F.Goto (st,(s,[ib1;ib2;ib3]))
- ))))
-
- (* have not a counter part in coccinelle, for the moment *)
- (* todo?: print a warning at least ? *)
- | _, F.CaseRange _
- | _, F.Asm _
- | _, F.MacroTop _
- -> fail2()
-
- | _, (F.IfdefEndif _|F.IfdefElse _|F.IfdefHeader _)
- -> fail2 ()
-
- | _,
- (F.MacroStmt (_, _)| F.DefineDoWhileZeroHeader _| F.EndNode|F.TopNode)
- -> fail
- | _,
- (F.Label (_, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
- F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
- F.DefineType _|F.DefineExpr _|F.DefineTodo|
- F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|F.MacroIterHeader (_, _)|
- F.SwitchHeader (_, _)|F.ForHeader (_, _)|F.DoWhileTail _|F.DoHeader (_, _)|
- F.WhileHeader (_, _)|F.Else _|F.IfHeader (_, _)|
- F.SeqEnd (_, _)|F.SeqStart (_, _, _)|
- F.Decl _|F.FunHeader _)
- -> fail
-
-
- )
-end
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-module A = Ast_cocci
-module B = Ast_c
-
-module F = Control_flow_c
-
-module Flag = Flag_matcher
-
-(*****************************************************************************)
-(* Wrappers *)
-(*****************************************************************************)
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-type sequence = Ordered | Unordered
-
-let seqstyle eas =
- match A.unwrap eas with
- | A.DOTS _ -> Ordered
- | A.CIRCLES _ -> Unordered
- | A.STARS _ -> failwith "not handling stars"
-
-let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
- A.rewrap eas (
- match A.unwrap eas with
- | A.DOTS _ -> A.DOTS easundots
- | A.CIRCLES _ -> A.CIRCLES easundots
- | A.STARS _ -> A.STARS easundots
- )
-
-
-let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
- fun ibs ->
- ibs +> List.exists (fun (ib, icomma) ->
- match B.unwrap ib with
- | B.InitDesignators _
- | B.InitFieldOld _
- | B.InitIndexOld _
- -> true
- | B.InitExpr _
- | B.InitList _
- -> false
- )
-
-(* For the #include <linux/...> in the .cocci, need to find where is
- * the '+' attached to this element, to later find the first concrete
- * #include <linux/xxx.h> or last one in the serie of #includes in the
- * .c.
- *)
-type include_requirement =
- | IncludeMcodeBefore
- | IncludeMcodeAfter
- | IncludeNothing
-
-
-
-(* todo? put in semantic_c.ml *)
-type info_ident =
- | Function
- | LocalFunction (* entails Function *)
- | DontKnow
-
-
-let term mc = A.unwrap_mcode mc
-let mcodekind mc = A.get_mcodekind mc
-
-
-let mcode_contain_plus = function
- | A.CONTEXT (_,A.NOTHING) -> false
- | A.CONTEXT _ -> true
- | A.MINUS (_,[]) -> false
- | A.MINUS (_,x::xs) -> true
- | A.PLUS -> raise Impossible
-
-let mcode_simple_minus = function
- | A.MINUS (_,[]) -> true
- | _ -> false
-
-
-(* In transformation.ml sometime I build some mcodekind myself and
- * julia has put None for the pos. But there is no possible raise
- * NoMatch in those cases because it is for the minusall trick or for
- * the distribute, so either have to build those pos, in fact a range,
- * because for the distribute have to erase a fullType with one
- * mcodekind, or add an argument to tag_with_mck such as "safe" that
- * don't do the check_pos. Hence this DontCarePos constructor. *)
-
-let minusizer =
- ("fake","fake"),
- {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
- (A.MINUS(A.DontCarePos, [])),
- A.NoMetaPos
-
-let generalize_mcode ia =
- let (s1, i, mck, pos) = ia in
- let new_mck =
- match mck with
- | A.PLUS -> raise Impossible
- | A.CONTEXT (A.NoPos,x) ->
- A.CONTEXT (A.DontCarePos,x)
- | A.MINUS (A.NoPos,x) ->
- A.MINUS (A.DontCarePos,x)
-
- | A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
- | A.MINUS ((A.FixPos _|A.DontCarePos), _)
- ->
- raise Impossible
- in
- (s1, i, new_mck, pos)
-
-
-
-(*---------------------------------------------------------------------------*)
-
-(* 0x0 is equivalent to 0, value format isomorphism *)
-let equal_c_int s1 s2 =
- try
- int_of_string s1 = int_of_string s2
- with Failure("int_of_string") ->
- s1 =$= s2
-
-
-
-(*---------------------------------------------------------------------------*)
-(* Normally A should reuse some types of Ast_c, so those
- * functions should not exist.
- *
- * update: but now Ast_c depends on A, so can't make too
- * A depends on Ast_c, so have to stay with those equal_xxx
- * functions.
- *)
-
-let equal_unaryOp a b =
- match a, b with
- | A.GetRef , B.GetRef -> true
- | A.DeRef , B.DeRef -> true
- | A.UnPlus , B.UnPlus -> true
- | A.UnMinus , B.UnMinus -> true
- | A.Tilde , B.Tilde -> true
- | A.Not , B.Not -> true
- | _, B.GetRefLabel -> false (* todo cocci? *)
- | _, (B.Not|B.Tilde|B.UnMinus|B.UnPlus|B.DeRef|B.GetRef) -> false
-
-
-
-let equal_arithOp a b =
- match a, b with
- | A.Plus , B.Plus -> true
- | A.Minus , B.Minus -> true
- | A.Mul , B.Mul -> true
- | A.Div , B.Div -> true
- | A.Mod , B.Mod -> true
- | A.DecLeft , B.DecLeft -> true
- | A.DecRight , B.DecRight -> true
- | A.And , B.And -> true
- | A.Or , B.Or -> true
- | A.Xor , B.Xor -> true
- | _, (B.Xor|B.Or|B.And|B.DecRight|B.DecLeft|B.Mod|B.Div|B.Mul|B.Minus|B.Plus)
- -> false
-
-let equal_logicalOp a b =
- match a, b with
- | A.Inf , B.Inf -> true
- | A.Sup , B.Sup -> true
- | A.InfEq , B.InfEq -> true
- | A.SupEq , B.SupEq -> true
- | A.Eq , B.Eq -> true
- | A.NotEq , B.NotEq -> true
- | A.AndLog , B.AndLog -> true
- | A.OrLog , B.OrLog -> true
- | _, (B.OrLog|B.AndLog|B.NotEq|B.Eq|B.SupEq|B.InfEq|B.Sup|B.Inf)
- -> false
-
-let equal_assignOp a b =
- match a, b with
- | A.SimpleAssign, B.SimpleAssign -> true
- | A.OpAssign a, B.OpAssign b -> equal_arithOp a b
- | _, (B.OpAssign _|B.SimpleAssign) -> false
-
-let equal_fixOp a b =
- match a, b with
- | A.Dec, B.Dec -> true
- | A.Inc, B.Inc -> true
- | _, (B.Inc|B.Dec) -> false
-
-let equal_binaryOp a b =
- match a, b with
- | A.Arith a, B.Arith b -> equal_arithOp a b
- | A.Logical a, B.Logical b -> equal_logicalOp a b
- | _, (B.Logical _ | B.Arith _) -> false
-
-let equal_structUnion a b =
- match a, b with
- | A.Struct, B.Struct -> true
- | A.Union, B.Union -> true
- | _, (B.Struct|B.Union) -> false
-
-let equal_sign a b =
- match a, b with
- | A.Signed, B.Signed -> true
- | A.Unsigned, B.UnSigned -> true
- | _, (B.UnSigned|B.Signed) -> false
-
-let equal_storage a b =
- match a, b with
- | A.Static , B.Sto B.Static
- | A.Auto , B.Sto B.Auto
- | A.Register , B.Sto B.Register
- | A.Extern , B.Sto B.Extern
- -> true
- | _, (B.NoSto | B.StoTypedef) -> false
- | _, (B.Sto (B.Register|B.Static|B.Auto|B.Extern)) -> false
-
-
-(*---------------------------------------------------------------------------*)
-
-let equal_metavarval valu valu' =
- match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
- | Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
- | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
- (* do something more ? *)
- a =$= b
-
- (* al_expr before comparing !!! and accept when they match.
- * Note that here we have Astc._expression, so it is a match
- * modulo isomorphism (there is no metavariable involved here,
- * just isomorphisms). => TODO call isomorphism_c_c instead of
- * =*=. Maybe would be easier to transform ast_c in ast_cocci
- * and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
- Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
- | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
- Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
-
- | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
- Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
- | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
- Lib_parsing_c.al_init a =*= Lib_parsing_c.al_init b
- | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
- (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
- C_vs_c.eq_type a b
-
- | Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
-
- | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
- Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
- | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
- Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
-
- | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
- Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
-
- | Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
- List.exists
- (function (fla,cea,posa1,posa2) ->
- List.exists
- (function (flb,ceb,posb1,posb2) ->
- fla = flb && cea = ceb &&
- Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
- l2)
- l1
-
- | (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
- |B.MetaTypeVal _ |B.MetaInitVal _
- |B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
- |B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
- ), _
- -> raise Impossible
-
-
-(*---------------------------------------------------------------------------*)
-(* could put in ast_c.ml, next to the split/unsplit_comma *)
-let split_signb_baseb_ii (baseb, ii) =
- let iis = ii +> List.map (fun info -> (B.str_of_info info), info) in
- match baseb, iis with
-
- | B.Void, ["void",i1] -> None, [i1]
-
- | B.FloatType (B.CFloat),["float",i1] -> None, [i1]
- | B.FloatType (B.CDouble),["double",i1] -> None, [i1]
- | B.FloatType (B.CLongDouble),["long",i1;"double",i2] -> None,[i1;i2]
-
- | B.IntType (B.CChar), ["char",i1] -> None, [i1]
-
-
- | B.IntType (B.Si (sign, base)), xs ->
- (match sign, base, xs with
- | B.Signed, B.CChar2, ["signed",i1;"char",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CChar2, ["unsigned",i1;"char",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CShort, ["short",i1] ->
- None, [i1]
- | B.Signed, B.CShort, ["signed",i1;"short",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2] ->
- Some (B.UnSigned, i1), [i2]
- | B.Signed, B.CShort, ["short",i1;"int",i2] ->
- None, [i1;i2]
-
- | B.Signed, B.CInt, ["int",i1] ->
- None, [i1]
- | B.Signed, B.CInt, ["signed",i1;"int",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CInt, ["unsigned",i1;"int",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CInt, ["signed",i1;] ->
- Some (B.Signed, i1), []
- | B.UnSigned, B.CInt, ["unsigned",i1;] ->
- Some (B.UnSigned, i1), []
-
- | B.Signed, B.CLong, ["long",i1] ->
- None, [i1]
- | B.Signed, B.CLong, ["long",i1;"int",i2] ->
- None, [i1;i2]
- | B.Signed, B.CLong, ["signed",i1;"long",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CLong, ["unsigned",i1;"long",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CLongLong, ["long",i1;"long",i2] -> None, [i1;i2]
- | B.Signed, B.CLongLong, ["signed",i1;"long",i2;"long",i3] ->
- Some (B.Signed, i1), [i2;i3]
- | B.UnSigned, B.CLongLong, ["unsigned",i1;"long",i2;"long",i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2; "int", i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
-
- | _ -> failwith "strange type1, maybe because of weird order"
- )
- | _ -> failwith "strange type2, maybe because of weird order"
-
-(*---------------------------------------------------------------------------*)
-
-let rec unsplit_icomma xs =
- match xs with
- | [] -> []
- | x::y::xs ->
- (match A.unwrap y with
- | A.IComma mcode ->
- (x, y)::unsplit_icomma xs
- | _ -> failwith "wrong ast_cocci in initializer"
- )
- | _ ->
- failwith ("wrong ast_cocci in initializer, should have pair " ^
- "number of Icomma")
-
-
-
-let resplit_initialiser ibs iicomma =
- match iicomma, ibs with
- | [], [] -> []
- | [], _ ->
- failwith "should have a iicomma, do you generate fakeInfo in parser?"
- | _, [] ->
- failwith "shouldn't have a iicomma"
- | [iicomma], x::xs ->
- let elems = List.map fst (x::xs) in
- let commas = List.map snd (x::xs) +> List.flatten in
- let commas = commas @ [iicomma] in
- zip elems commas
- | _ -> raise Impossible
-
-
-
-let rec split_icomma xs =
- match xs with
- | [] -> []
- | (x,y)::xs -> x::y::split_icomma xs
-
-let rec unsplit_initialiser ibs_unsplit =
- match ibs_unsplit with
- | [] -> [], [] (* empty iicomma *)
- | (x, commax)::xs ->
- let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
- (x, [])::xs, lastcomma
-
-and unsplit_initialiser_bis comma_before = function
- | [] -> [], [comma_before]
- | (x, commax)::xs ->
- let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
- (x, [comma_before])::xs, lastcomma
-
-
-
-
-(*---------------------------------------------------------------------------*)
-(* coupling: same in type_annotater_c.ml *)
-let structdef_to_struct_name ty =
- match ty with
- | qu, (B.StructUnion (su, sopt, fields), iis) ->
- (match sopt,iis with
- | Some s , [i1;i2;i3;i4] ->
- qu, (B.StructUnionName (su, s), [i1;i2])
- | None, _ ->
- ty
-
- | x -> raise Impossible
- )
- | _ -> raise Impossible
-
-(*---------------------------------------------------------------------------*)
-let initialisation_to_affectation decl =
- match decl with
- | B.MacroDecl _ -> F.Decl decl
- | B.DeclList (xs, iis) ->
-
- (* todo?: should not do that if the variable is an array cos
- * will have x[] = , mais de toute facon ca sera pas un InitExp
- *)
- (match xs with
- | [] -> raise Impossible
- | [x] ->
- let ({B.v_namei = var;
- B.v_type = returnType;
- B.v_storage = storage;
- B.v_local = local},
- iisep) = x in
-
- (match var with
- | Some ((s, ini), iis::iini) ->
- (match ini with
- | Some (B.InitExpr e, ii_empty2) ->
- let local =
- match local with
- Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
- | Ast_c.LocalDecl -> Ast_c.LocalVar (iis.Ast_c.pinfo) in
-
- let typ =
- ref (Some ((Lib_parsing_c.al_type returnType),local),
- Ast_c.NotTest) in
- let id = (B.Ident s, typ),[iis] in
- F.DefineExpr
- ((B.Assignment (id, B.SimpleAssign, e),
- Ast_c.noType()), iini)
- | _ -> F.Decl decl
- )
- | _ -> F.Decl decl
- )
- | x::xs ->
- pr2_once "TODO: initialisation_to_affectation for multi vars";
- (* todo? do a fold_left and generate 'x = a, y = b' etc, use
- * the Sequence expression operator of C and make an
- * ExprStatement from that.
- *)
- F.Decl decl
- )
-
-
-
-
-
-(*****************************************************************************)
-(* Functor parameter combinators *)
-(*****************************************************************************)
-(* monad like stuff
- * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
- *
- * version0: was not tagging the SP, so just tag the C
- * val (>>=):
- * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
- * val return : 'b -> tin -> 'b tout
- * val fail : tin -> 'b tout
- *
- * version1: now also tag the SP so return a ('a * 'b)
- *)
-
-type mode = PatternMode | TransformMode
-
-module type PARAM =
- sig
- type tin
- type 'x tout
-
-
- type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
-
- val mode : mode
-
- val (>>=):
- (tin -> ('a * 'b) tout) ->
- ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
- (tin -> ('c * 'd) tout)
-
- val return : ('a * 'b) -> tin -> ('a *'b) tout
- val fail : tin -> ('a * 'b) tout
-
- val (>||>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>|+|>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>&&>) : (tin -> bool) -> (tin -> 'x tout) -> (tin -> 'x tout)
-
- val tokenf : ('a A.mcode, B.info) matcher
- val tokenf_mck : (A.mcodekind, B.info) matcher
-
- val distrf_e :
- (A.meta_name A.mcode, B.expression) matcher
- val distrf_args :
- (A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
- val distrf_type :
- (A.meta_name A.mcode, Ast_c.fullType) matcher
- val distrf_params :
- (A.meta_name A.mcode,
- (Ast_c.parameterType, Ast_c.il) either list) matcher
- val distrf_param :
- (A.meta_name A.mcode, Ast_c.parameterType) matcher
- val distrf_ini :
- (A.meta_name A.mcode, Ast_c.initialiser) matcher
- val distrf_node :
- (A.meta_name A.mcode, Control_flow_c.node) matcher
-
- val distrf_define_params :
- (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
- matcher
-
- val distrf_struct_fields :
- (A.meta_name A.mcode, B.field list) matcher
-
- val distrf_cst :
- (A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
-
- val cocciExp :
- (A.expression, B.expression) matcher -> (A.expression, F.node) matcher
-
- val cocciExpExp :
- (A.expression, B.expression) matcher ->
- (A.expression, B.expression) matcher
-
- val cocciTy :
- (A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
-
- val cocciInit :
- (A.initialiser, B.initialiser) matcher -> (A.initialiser, F.node) matcher
-
- val envf :
- A.keep_binding -> A.inherited ->
- A.meta_name A.mcode * Ast_c.metavar_binding_kind *
- (unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val check_constraints :
- ('a, 'b) matcher -> 'a list -> 'b ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val all_bound : A.meta_name list -> (tin -> bool)
-
- val optional_storage_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
-
-
- end
-
-(*****************************************************************************)
-(* Functor code, "Cocci vs C" *)
-(*****************************************************************************)
-
-module COCCI_VS_C =
- functor (X : PARAM) ->
-struct
-
-type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
-
-let (>>=) = X.(>>=)
-let return = X.return
-let fail = X.fail
-
-let (>||>) = X.(>||>)
-let (>|+|>) = X.(>|+|>)
-let (>&&>) = X.(>&&>)
-
-let tokenf = X.tokenf
-
-(* should be raise Impossible when called from transformation.ml *)
-let fail2 () =
- match X.mode with
- | PatternMode -> fail
- | TransformMode -> raise Impossible
-
-
-let (option: ('a,'b) matcher -> ('a option,'b option) matcher)= fun f t1 t2 ->
- match (t1,t2) with
- | (Some t1, Some t2) ->
- f t1 t2 >>= (fun t1 t2 ->
- return (Some t1, Some t2)
- )
- | (None, None) -> return (None, None)
- | _ -> fail
-
-(* Dots are sometimes used as metavariables, since like metavariables they
-can match other things. But they no longer have the same type. Perhaps these
-functions could be avoided by introducing an appropriate level of polymorphism,
-but I don't know how to declare polymorphism across functors *)
-let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
-let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
-
-(*---------------------------------------------------------------------------*)
-(* toc:
- * - expression
- * - ident
- * - arguments
- * - parameters
- * - declaration
- * - initialisers
- * - type
- * - node
- *)
-
-(*---------------------------------------------------------------------------*)
-let rec (expression: (A.expression, Ast_c.expression) matcher) =
- fun ea eb ->
- X.all_bound (A.get_inherited ea) >&&>
- let wa x = A.rewrap ea x in
- match A.unwrap ea, eb with
-
- (* general case: a MetaExpr can match everything *)
- | A.MetaExpr (ida,constraints,keep,opttypa,form,inherited),
- (((expr, opttypb), ii) as expb) ->
-
- (* old: before have a MetaConst. Now we factorize and use 'form' to
- * differentiate between different cases *)
- let rec matches_id = function
- B.Ident(c) -> true
- | B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
- | _ -> false in
- let form_ok =
- match (form,expr) with
- (A.ANY,_) -> true
- | (A.CONST,e) ->
- let rec matches = function
- B.Constant(c) -> true
- | B.Ident idb when idb =~ "^[A-Z_][A-Z_0-9]*$" ->
- pr2_once ("warning: I consider " ^ idb ^ " as a constant");
- true
- | B.Cast(ty,e) -> matches (B.unwrap_expr e)
- | B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
- | B.SizeOfExpr(exp) -> true
- | B.SizeOfType(ty) -> true
- | _ -> false in
- matches e
- | (A.LocalID,e) ->
- (matches_id e) &&
- (match !opttypb with
- (Some (_,Ast_c.LocalVar _),_) -> true
- | _ -> false)
- | (A.ID,e) -> matches_id e in
-
- if form_ok
- then
- (let (opttypb,_testb) = !opttypb in
- match opttypa, opttypb with
- | None, _ -> return ((),())
- | Some _, None ->
- pr2_once ("Missing type information. Certainly a pb in " ^
- "annotate_typer.ml");
- fail
-
- | Some tas, Some tb ->
- tas +> List.fold_left (fun acc ta ->
- acc >|+|> compatible_type ta tb) fail
- ) >>=
- (fun () () ->
- X.check_constraints expression constraints eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>= (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )))
- else fail
-
- (* old:
- * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
- * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
- *
- * but bug! because if have not tagged SP, then transform without doing
- * any checks. Hopefully now have tagged SP technique.
- *)
-
-
- (* old:
- * | A.Edots _, _ -> raise Impossible.
- *
- * In fact now can also have the Edots inside normal expression, not
- * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
- *)
- | A.Edots (mcode, None), expb ->
- X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
- return (
- A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
- expb
- ))
-
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
-
- | A.Ident ida, ((B.Ident idb, typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- return (
- ((A.Ident ida)) +> wa,
- ((B.Ident idb, typ),[ib1])
- ))
-
-
-
-
- | A.MetaErr _, _ -> failwith "not handling MetaErr"
-
- (* todo?: handle some isomorphisms in int/float ? can have different
- * format : 1l can match a 1.
- *
- * todo: normally string can contain some metavar too, so should
- * recurse on the string
- *)
- | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
- (* for everything except the String case where can have multi elems *)
- let do1 () =
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
- ((B.Constant (ib), typ),[ib1])
- ))
- in
- (match term ia1, ib with
- | A.Int x, B.Int y ->
- X.value_format_flag (fun use_value_equivalence ->
- if use_value_equivalence
- then
- if equal_c_int x y
- then do1()
- else fail
- else
- if x =$= y
- then do1()
- else fail
- )
- | A.Char x, B.Char (y,_) when x =$= y (* todo: use kind ? *)
- -> do1()
- | A.Float x, B.Float (y,_) when x =$= y (* todo: use floatType ? *)
- -> do1()
-
- | A.String sa, B.String (sb,_kind) when sa =$= sb ->
- (match ii with
- | [ib1] ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
- ((B.Constant (ib), typ),[ib1])
- ))
- | _ -> fail (* multi string, not handled *)
- )
-
- | _, B.MultiString -> (* todo cocci? *) fail
- | _, (B.String _ | B.Float _ | B.Char _ | B.Int _) -> fail
- )
-
-
- | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
- (* todo: do special case to allow IdMetaFunc, cos doing the
- * recursive call will be too late, match_ident will not have the
- * info whether it was a function. todo: but how detect when do
- * x.field = f; how know that f is a Func ? By having computed
- * some information before the matching!
- *
- * Allow match with FunCall containing types. Now ast_cocci allow
- * type in parameter, and morover ast_cocci allow f(...) and those
- * ... could match type.
- *)
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- ((A.FunCall (ea, ia1, eas, ia2)) +> wa,
- ((B.FunCall (eb, ebs),typ), [ib1;ib2])
- ))))))
-
-
-
-
- | A.Assignment (ea1, opa, ea2, simple),
- ((B.Assignment (eb1, opb, eb2), typ),ii) ->
- let (opbi) = tuple_of_list1 ii in
- if equal_assignOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
- ((B.Assignment (eb1, opb, eb2), typ), [opbi])
- ))))
- else fail
-
- | A.CondExpr(ea1,ia1,ea2opt,ia2,ea3),((B.CondExpr(eb1,eb2opt,eb3),typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- expression ea3 eb3 >>= (fun ea3 eb3 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.CondExpr(ea1,ia1,ea2opt,ia2,ea3))) +> wa,
- ((B.CondExpr (eb1, eb2opt, eb3),typ), [ib1;ib2])
- ))))))
-
- (* todo?: handle some isomorphisms here ? *)
- | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_fixOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Postfix (ea, opa))) +> wa,
- ((B.Postfix (eb, opb), typ),[opbi])
- )))
- else fail
-
-
- | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_fixOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Infix (ea, opa))) +> wa,
- ((B.Infix (eb, opb), typ),[opbi])
- )))
- else fail
-
- | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_unaryOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Unary (ea, opa))) +> wa,
- ((B.Unary (eb, opb), typ),[opbi])
- )))
- else fail
-
- | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_binaryOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Binary (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))
- else fail
-
- | A.Nested (ea1, opa, ea2), eb ->
- let rec loop eb =
- (if A.get_test_exp ea1 && not (Ast_c.is_test eb) then fail
- else expression ea1 eb) >|+|>
- (match eb with
- ((B.Binary (eb1, opb, eb2), typ),ii)
- when equal_binaryOp (term opa) opb ->
- let opbi = tuple_of_list1 ii in
- let left_to_right =
- (expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let right_to_left =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- expression ea1 eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let in_left =
- (loop eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let in_right =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- loop eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
- | _ -> fail) in
- loop eb
-
- (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
- | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.ArrayAccess (ea1, ia1, ea2, ia2))) +> wa,
- ((B.ArrayAccess (eb1, eb2),typ), [ib1;ib2])
- )))))
-
- (* todo?: handle some isomorphisms here ? *)
- | A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
- return (
- ((A.RecordAccess (ea, ia1, ida))) +> wa,
- ((B.RecordAccess (eb, idb), typ), [ib1;ib2])
- ))))
-
-
-
- | A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
- return (
- ((A.RecordPtAccess (ea, ia1, ida))) +> wa,
- ((B.RecordPtAccess (eb, idb), typ), [ib1;ib2])
- ))))
-
-
- (* todo?: handle some isomorphisms here ?
- * todo?: do some iso-by-absence on cast ?
- * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
- *)
-
- | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.Cast (ia1, typa, ia2, ea))) +> wa,
- ((B.Cast (typb, eb),typ),[ib1;ib2])
- )))))
-
- | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.SizeOfExpr (ia1, ea))) +> wa,
- ((B.SizeOfExpr (eb), typ),[ib1])
- )))
-
- | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- ((A.SizeOfType (ia1, ia2, typa, ia3))) +> wa,
- ((B.SizeOfType (typb),typ),[ib1;ib2;ib3])
- )))))
-
-
- (* todo? iso ? allow all the combinations ? *)
- | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.Paren (ia1, ea, ia2))) +> wa,
- ((B.ParenExpr (eb), typ), [ib1;ib2])
- ))))
-
- | A.NestExpr(exps,None,true), eb ->
- (match A.unwrap exps with
- A.DOTS [exp] ->
- X.cocciExpExp expression exp eb >>= (fun exp eb ->
- return (
- (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
- eb
- )
- )
- | _ ->
- failwith
- "for nestexpr, only handling the case with dots and only one exp")
-
- | A.NestExpr _, _ ->
- failwith "only handling multi and no when code in a nest expr"
-
- (* only in arg lists or in define body *)
- | A.TypeExp _, _ -> fail
-
- (* only in arg lists *)
- | A.MetaExprList _, _
- | A.EComma _, _
- | A.Ecircles _, _
- | A.Estars _, _
- ->
- raise Impossible
-
- | A.DisjExpr eas, eb ->
- eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
-
- | A.UniqueExp _,_ | A.OptExp _,_ ->
- failwith "not handling Opt/Unique/Multi on expr"
-
- (* Because of Exp cant put a raise Impossible; have to put a fail *)
-
- (* have not a counter part in coccinelle, for the moment *)
- | _, ((B.Sequence _,_),_)
- | _, ((B.StatementExpr _,_),_)
- | _, ((B.Constructor _,_),_)
- -> fail
-
-
- | _,
- (((B.Cast (_, _)|B.ParenExpr _|B.SizeOfType _|B.SizeOfExpr _|
- B.RecordPtAccess (_, _)|
- B.RecordAccess (_, _)|B.ArrayAccess (_, _)|
- B.Binary (_, _, _)|B.Unary (_, _)|
- B.Infix (_, _)|B.Postfix (_, _)|
- B.Assignment (_, _, _)|B.CondExpr (_, _, _)|
- B.FunCall (_, _)|B.Constant _|B.Ident _),
- _),_)
- -> fail
-
-
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
- fun infoidb ida ((idb, iib) as ib) ->
- X.all_bound (A.get_inherited ida) >&&>
- match A.unwrap ida with
- | A.Id sa ->
- if (term sa) =$= idb then
- tokenf sa iib >>= (fun sa iib ->
- return (
- ((A.Id sa)) +> A.rewrap ida,
- (idb, iib)
- ))
- else fail
-
-
- | A.MetaId(mida,constraints,keep,inherited) ->
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- (* use drop_pos for ids so that the pos is not added a second time in
- the call to tokenf *)
- X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
- (idb, iib)
- )))
- ))
-
- | A.MetaFunc(mida,constraints,keep,inherited) ->
- let is_function _ =
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
- (idb, iib)
- ))
- )) in
- (match infoidb with
- | LocalFunction | Function -> is_function()
- | DontKnow ->
- failwith "MetaFunc, need more semantic info about id"
- (* the following implementation could possibly be useful, if one
- follows the convention that a macro is always in capital letters
- and that a macro is not a function.
- (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
- )
-
- | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
- (match infoidb with
- | LocalFunction ->
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- X.envf keep inherited
- (A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaLocalFunc(mida,constraints,keep,inherited)))
- +> A.rewrap ida,
- (idb, iib)
- ))
- ))
- | Function -> fail
- | DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
- )
-
- | A.OptIdent _ | A.UniqueIdent _ ->
- failwith "not handling Opt/Unique for ident"
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (arguments: sequence ->
- (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-(* because '...' can match nothing, need to take care when have
- * ', ...' or '...,' as in f(..., X, Y, ...). It must match
- * f(1,2) for instance.
- * So I have added special cases such as (if startxs = []) and code
- * in the Ecomma matching rule.
- *
- * old: Must do some try, for instance when f(...,X,Y,...) have to
- * test the transfo for all the combinaitions and if multiple transfo
- * possible ? pb ? => the type is to return a expression option ? use
- * some combinators to help ?
- * update: with the tag-SP approach, no more a problem.
- *)
-
-and arguments_bis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Edots (mcode, optexpr), ys ->
- (* todo: if optexpr, then a WHEN and so may have to filter yys *)
- if optexpr <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (* allow '...', and maybe its associated ',' to match nothing.
- * for the associated ',' see below how we handle the EComma
- * to match nothing.
- *)
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (* subtil: we dont want the '...' to match until the
- * comma. cf -test pb_params_iso. We would get at
- * "already tagged" error.
- * this is because both f (... x, ...) and f (..., x, ...)
- * would match a f(x,3) with our "optional-comma" strategy.
- *)
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_args (dots2metavar mcode) startxs
- )
- )
- >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.EComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.EComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
- | A.EComma ia1, ebs ->
- (* allow ',' to maching nothing. optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else arguments_bis eas ebs
-
- | A.MetaExprList(ida,leninfo,keep,inherited),ys ->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- | Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_args startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaExprListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_args ida (Ast_c.split_comma startxs')
- )
- >>= (fun ida startxs ->
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaExprList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- )
- )) fail
-
-
- | _unwrapx, (Left eb)::ebs ->
- argument ea eb >>= (fun ea eb ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (ea::eas, Left eb::ebs)
- ))
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-and argument arga argb =
- X.all_bound (A.get_inherited arga) >&&>
- match A.unwrap arga, argb with
- | A.TypeExp tya, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
-
- if b || sopt <> None
- then
- (* failwith "the argument have a storage and ast_cocci does not have"*)
- fail
- else
- fullType tya tyb >>= (fun tya tyb ->
- return (
- (A.TypeExp tya) +> A.rewrap arga,
- (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
- ))
-
- | A.TypeExp tya, _ -> fail
- | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
- | _, Left argb ->
- expression arga argb >>= (fun arga argb ->
- return (arga, Left argb)
- )
- | _, Right (B.ArgAction y) -> fail
-
-
-(* ------------------------------------------------------------------------- *)
-(* todo? facto code with argument ? *)
-and (parameters: sequence ->
- (A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
- matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-
-and parameters_bis eas ebs =
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- (* the management of positions is inlined into each case, because
- sometimes there is a Param and sometimes a ParamList *)
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Pdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on"*)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Pdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.PComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.PComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.PComma ia1, ebs ->
- (* try optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else parameters_bis eas ebs
-
-
- | A.MetaParamList(ida,leninfo,keep,inherited),ys->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "I have no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_params startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaParamListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_params ida (Ast_c.split_comma startxs')
- ) >>= (fun ida startxs ->
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaParamList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- ))
- ) fail
-
-
- | A.VoidParam ta, ys ->
- (match eas, ebs with
- | [], [Left eb] ->
- let ((hasreg, idbopt, tb), ii_b_s) = eb in
- if idbopt = None && null ii_b_s
- then
- match tb with
- | (qub, (B.BaseType B.Void,_)) ->
- fullType ta tb >>= (fun ta tb ->
- return (
- [(A.VoidParam ta) +> A.rewrap ea],
- [Left ((hasreg, idbopt, tb), ii_b_s)]
- ))
- | _ -> fail
- else fail
- | _ -> fail
- )
-
- | (A.OptParam _ | A.UniqueParam _), _ ->
- failwith "handling Opt/Unique for Param"
-
- | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
-
- | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
- (* todo: use quaopt, hasreg ? *)
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
- X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
- X.distrf_param ida eb
- ) >>= (fun ida eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
- (Left eb)::ebs
- )))
-
-
- | A.Param (typa, idaopt), (Left eb)::ebs ->
- (*this should succeed if the C code has a name, and fail otherwise*)
- parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
- (Left eb)::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-
-
-and parameter = fun (idaopt, typa) ((hasreg, idbopt, typb), ii_b_s) ->
- fullType typa typb >>= (fun typa typb ->
- match idaopt, Ast_c.split_register_param (hasreg, idbopt, ii_b_s) with
- | Some ida, Left (idb, iihasreg, iidb) ->
- (* todo: if minus on ida, should also minus the iihasreg ? *)
- ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
- return (
- (Some ida, typa),
- ((hasreg, Some idb, typb), iihasreg++[iidb])
- ))
-
- | None, Right iihasreg ->
- return (
- (None, typa),
- ((hasreg, None, typb), iihasreg)
- )
-
-
- (* why handle this case ? because of transform_proto ? we may not
- * have an ident in the proto.
- * If have some plus on ida ? do nothing about ida ?
- *)
- (* not anymore !!! now that julia is handling the proto.
- | _, Right iihasreg ->
- return (
- (idaopt, typa),
- ((hasreg, None, typb), iihasreg)
- )
- *)
-
- | Some _, Right _ -> fail
- | None, Left _ -> fail
- )
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
- fun (mckstart, allminus, decla) declb ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
- * de toutes les declarations qui sont au debut d'un fonction et
- * commencer le reste du match au premier statement. Alors, ca matche
- * n'importe quelle declaration. On n'a pas besoin d'ajouter
- * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
- *
- * When the SP want to remove the whole function, the minus is not
- * on the MetaDecl but on the MetaRuleElem. So there should
- * be no transform of MetaDecl, just matching are allowed.
- *)
-
- | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
- (* todo: should not happen in transform mode *)
- return ((mckstart, allminus, decla), declb)
-
-
-
- | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
- onedecl allminus decla (var,iiptvirgb,iisto) >>=
- (fun decla (var,iiptvirgb,iisto)->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))
-
- | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
- if X.mode = PatternMode
- then
- xs +> List.fold_left (fun acc var ->
- acc >||> (
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- onedecl allminus decla (var, iiptvirgb, iisto) >>=
- (fun decla (var, iiptvirgb, iisto) ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))))
- fail
- else
- failwith "More that one variable in decl. Have to split to transform."
-
- | A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
- let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
- (match ii with
- | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
- (iisb,lpb,rpb,iiendb, iifakestart,iisto)
- | _ -> raise Impossible
- ) in
- (if allminus
- then minusize_list iistob
- else return ((), iistob)
- ) >>= (fun () iistob ->
-
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- ident DontKnow sa (sb, iisb) >>= (fun sa (sb, iisb) ->
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- tokenf enda iiendb >>= (fun enda iiendb ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
-
- return (
- (mckstart, allminus,
- (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
- (B.MacroDecl ((sb,ebs),
- [iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
- ))))))))
-
- | _, (B.MacroDecl _ |B.DeclList _) -> fail
-
-
-
-and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* kind of typedef iso, we must unfold, it's for the case
- * T { }; that we want to match against typedef struct { } xx_t;
- *)
- | A.TyDecl (tya0, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- (match A.unwrap tya0, typb0 with
- | A.Type(cv1,tya1), ((qu,il),typb1) ->
-
- (match A.unwrap tya1, typb1 with
- | A.StructUnionDef(tya2, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
-
- let (iisub, iisbopt, lbb, rbb) =
- match sbopt with
- | None ->
- let (iisub, lbb, rbb) = tuple_of_list3 ii in
- (iisub, [], lbb, rbb)
- | Some s ->
- pr2 (sprintf
- "warning: both a typedef (%s) and struct name introduction (%s)"
- idb s
- );
- pr2 "warning: I will consider only the typedef";
- let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
- (iisub, [iisb], lbb, rbb)
- in
- let structnameb =
- structdef_to_struct_name
- (Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
- in
- let fake_typeb =
- Ast_c.nQ,((B.TypeName (idb, Some
- (Lib_parsing_c.al_type structnameb))), [iidb])
- in
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
- struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
- let declsa = redots declsa undeclsa in
-
- (match A.unwrap tya2 with
- | A.Type(cv3, tya3) ->
- (match A.unwrap tya3 with
- | A.MetaType(ida,keep, inherited) ->
-
- fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
- let tya1 =
- A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1 in
- let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
-
- let typb1 = B.StructUnion (sub,sbopt, declsb),
- [iisub] @ iisbopt @ [lbb;rbb] in
- let typb0 = ((qu, il), typb1) in
-
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
-
- | A.StructUnionName(sua, sa) ->
-
- fullType tya2 structnameb >>= (fun tya2 structnameb ->
-
- let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
- in
- let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
- match structnameb with
- | _nQ, (B.StructUnionName (sub, s), [iisub;iisbopt]) ->
-
- let typb1 = B.StructUnion (sub,sbopt, declsb),
- [iisub;iisbopt;lbb;rbb] in
- let typb0 = ((qu, il), typb1) in
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
- | _ -> raise Impossible
- )
- | _ -> fail
- )))))
- | _ -> fail
- )
- | _ -> fail
- )
-
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
-
-
-
- (* could handle iso here but handled in standard.iso *)
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- return (
- (A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb,None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg),
- iiptvirgb,iistob)
- )))))
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg)
- ->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf eqa iieqb >>= (fun eqa iieqb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg),
- iiptvirgb,iistob)
- )))))))
-
- (* do iso-by-absence here ? allow typedecl and var ? *)
- | A.TyDecl (typa, ptvirga),
- ({B.v_namei = None; B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- if stob = (B.NoSto, false)
- then
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- return (
- (A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = None;
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg), iiptvirgb, iistob)
- )))
- else fail
-
-
- | A.Typedef (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = (B.StoTypedef,inline);
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- (match iistob with
- | [iitypedef] ->
- tokenf stoa iitypedef >>= (fun stoa iitypedef ->
- return (stoa, [iitypedef])
- )
- | _ -> failwith "wierd, have both typedef and inline or nothing";
- ) >>= (fun stoa iistob ->
- (match A.unwrap ida with
- | A.MetaType(_,_,_) ->
-
- let fake_typeb =
- Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
- in
- fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
- return (ida, (idb, iidb))
- | _ -> raise Impossible
- )
-
- | A.TypeName sa ->
- if (term sa) =$= idb
- then
- tokenf sa iidb >>= (fun sa iidb ->
- return (
- (A.TypeName sa) +> A.rewrap ida,
- (idb, iidb)
- ))
- else fail
- | _ -> raise Impossible
-
- ) >>= (fun ida (idb, iidb) ->
- return (
- (A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = (B.StoTypedef,inline);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),
- iiptvirgb, iistob)
- )
- ))))
-
-
- | _, ({B.v_namei = None;}, _) ->
- (* old: failwith "no variable in this declaration, wierd" *)
- fail
-
-
-
- | A.DisjDecl declas, declb ->
- declas +> List.fold_left (fun acc decla ->
- acc >|+|>
- (* (declaration (mckstart, allminus, decla) declb) *)
- (onedecl allminus decla (declb,iiptvirgb, iistob))
- ) fail
-
-
-
- (* only in struct type decls *)
- | A.Ddots(dots,whencode), _ ->
- raise Impossible
-
- | A.OptDecl _, _ | A.UniqueDecl _, _ ->
- failwith "not handling Opt/Unique Decl"
-
- | _, ({B.v_namei=Some _}, _)
- -> fail
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-
-and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
- X.all_bound (A.get_inherited ia) >&&>
- match (A.unwrap ia,ib) with
-
- | (A.MetaInit(ida,keep,inherited), ib) ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_ini ib) in
- X.envf keep inherited (ida, Ast_c.MetaInitVal ib, max_min)
- (fun () ->
- X.distrf_ini ida ib >>= (fun ida ib ->
- return (
- A.MetaInit (ida,keep,inherited) +> A.rewrap ia,
- ib
- ))
- )
-
- | (A.InitExpr expa, ib) ->
- (match A.unwrap expa, ib with
- | A.Edots (mcode, None), ib ->
- X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
- return (
- A.InitExpr
- (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
- +> A.rewrap ia,
- ib
- ))
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
- | _, (B.InitExpr expb, ii) ->
- assert (null ii);
- expression expa expb >>= (fun expa expb ->
- return (
- (A.InitExpr expa) +> A.rewrap ia,
- (B.InitExpr expb, ii)
- ))
- | _ -> fail
- )
-
- | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
- (match ii with
- | ib1::ib2::iicommaopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
- return (
- (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
- (B.InitList ibs, ib1::ib2::iicommaopt)
- ))))
-
- | _ -> raise Impossible
- )
-
- | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
- failwith "TODO: not handling whencode in initialisers"
-
-
- | (A.InitGccExt (designatorsa, ia2, inia),
- (B.InitDesignators (designatorsb, inib), ii2))->
-
- let iieq = tuple_of_list1 ii2 in
-
- tokenf ia2 iieq >>= (fun ia2 iieq ->
- designators designatorsa designatorsb >>=
- (fun designatorsa designatorsb ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccExt (designatorsa, ia2, inia)) +> A.rewrap ia,
- (B.InitDesignators (designatorsb, inib), [iieq])
- ))))
-
-
-
-
- | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
- (match ii with
- | [iidb;iicolon] ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- initialiser inia inib >>= (fun inia inib ->
- tokenf ia1 iicolon >>= (fun ia1 iicolon ->
- return (
- (A.InitGccName (ida, ia1, inia)) +> A.rewrap ia,
- (B.InitFieldOld (idb, inib), [iidb;iicolon])
- ))))
- | _ -> fail
- )
-
-
-
- | A.IComma(comma), _ ->
- raise Impossible
-
- | A.UniqueIni _,_ | A.OptIni _,_ ->
- failwith "not handling Opt/Unique on initialisers"
-
- | _, (B.InitIndexOld (_, _), _) -> fail
- | _, (B.InitFieldOld (_, _), _) -> fail
-
- | _, ((B.InitDesignators (_, _)|B.InitList _|B.InitExpr _), _)
- -> fail
-
-and designators dla dlb =
- match (dla,dlb) with
- ([],[]) -> return ([], [])
- | ([],_) | (_,[]) -> fail
- | (da::dla,db::dlb) ->
- designator da db >>= (fun da db ->
- designators dla dlb >>= (fun dla dlb ->
- return (da::dla, db::dlb)))
-
-and designator da db =
- match (da,db) with
- (A.DesignatorField (ia1, ida), (B.DesignatorField idb,ii1)) ->
-
- let (iidot, iidb) = tuple_of_list2 ii1 in
- tokenf ia1 iidot >>= (fun ia1 iidot ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- return (
- A.DesignatorField (ia1, ida),
- (B.DesignatorField idb, [iidot;iidb])
- )))
-
- | (A.DesignatorIndex (ia1,ea,ia2), (B.DesignatorIndex eb, ii1)) ->
-
- let (ib1, ib2) = tuple_of_list2 ii1 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.DesignatorIndex (ia1,ea,ia2),
- (B.DesignatorIndex eb, [ib1;ib2])
- ))))
-
- | (A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
- (B.DesignatorRange (e1b, e2b), ii1)) ->
-
- let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression e1a e1b >>= (fun e1a e1b ->
- expression e2a e2b >>= (fun e2a e2b ->
- return (
- A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
- (B.DesignatorRange (e1b, e2b), [ib1;ib2;ib3])
- ))))))
- | (_, ((B.DesignatorField _|B.DesignatorIndex _|B.DesignatorRange _), _)) ->
- fail
-
-
-and initialisers = fun ias (ibs, iicomma) ->
- let ias_unsplit = unsplit_icomma ias in
- let ibs_split = resplit_initialiser ibs iicomma in
-
- let f =
- if need_unordered_initialisers ibs
- then initialisers_unordered2
- else initialisers_ordered2
- in
- f ias_unsplit ibs_split >>=
- (fun ias_unsplit ibs_split ->
- return (
- split_icomma ias_unsplit,
- unsplit_initialiser ibs_split
- )
- )
-
-(* todo: one day julia will reput a IDots *)
-and initialisers_ordered2 = fun ias ibs ->
- match ias, ibs with
- | [], [] -> return ([], [])
- | (x, xcomma)::xs, (y, commay)::ys ->
- (match A.unwrap xcomma with
- | A.IComma commax ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- initialisers_ordered2 xs ys >>= (fun xs ys ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
- (y, commay)::ys
- )
- )))
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- | _ -> fail
-
-
-
-and initialisers_unordered2 = fun ias ibs ->
-
- match ias, ibs with
- | [], ys -> return ([], ys)
- | (x,xcomma)::xs, ys ->
-
- let permut = Common.uncons_permut_lazy ys in
- permut +> List.fold_left (fun acc ((e, pos), rest) ->
- acc >||>
- (
- (match A.unwrap xcomma, e with
- | A.IComma commax, (y, commay) ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma),
- (y, commay))
- )
- )
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- >>= (fun x e ->
- let rest = Lazy.force rest in
- initialisers_unordered2 xs rest >>= (fun xs rest ->
- return (
- x::xs,
- Common.insert_elem_pos (e, pos) rest
- ))))
- ) fail
-
-
-(* ------------------------------------------------------------------------- *)
-and (struct_fields: (A.declaration list, B.field list) matcher) =
- fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Ddots (mcode, optwhen), ys ->
- if optwhen <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
-
- X.distrf_struct_fields (dots2metavar mcode) startxs
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- struct_fields eas endxs >>= (fun eas endxs ->
- return (
- (A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
- | _unwrapx, eb::ebs ->
- struct_field ea eb >>= (fun ea eb ->
- struct_fields eas ebs >>= (fun eas ebs ->
- return (ea::eas, eb::ebs)
- ))
-
- | _unwrapx, [] -> fail
- )
-
-and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
- let (xfield, iifield) = fb in
-
- match xfield with
- | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
-
- let iiptvirgb = tuple_of_list1 iiptvirg in
-
- (match onefield_multivars with
- | [] -> raise Impossible
- | [onevar,iivirg] ->
- assert (null iivirg);
- (match onevar with
- | B.BitField (sopt, typb, expr), ii ->
- pr2_once "warning: bitfield not handled by ast_cocci";
- fail
- | B.Simple (None, typb), ii ->
- pr2_once "warning: unamed struct field not handled by ast_cocci";
- fail
- | B.Simple (Some idb, typb), ii ->
- let (iidb) = tuple_of_list1 ii in
-
- (* build a declaration from a struct field *)
- let allminus = false in
- let iisto = [] in
- let stob = B.NoSto, false in
- let fake_var =
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = Ast_c.NotLocalDecl;
- B.v_attr = Ast_c.noattr;
- },
- iivirg)
- in
- onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
- (fun fa (var,iiptvirgb,iisto) ->
-
- match fake_var with
- | ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- }, iivirg) ->
- let onevar = B.Simple (Some idb, typb), [iidb] in
-
- return (
- (fa),
- ((B.DeclarationField
- (B.FieldDeclList ([onevar, iivirg], [iiptvirgb]))),
- iifield)
- )
- | _ -> raise Impossible
- )
- )
-
- | x::y::xs ->
- pr2_once "PB: More that one variable in decl. Have to split";
- fail
- )
- | B.EmptyField ->
- let _iiptvirgb = tuple_of_list1 iifield in
- fail
-
- | B.MacroStructDeclTodo -> fail
- | B.CppDirectiveStruct directive -> fail
- | B.IfdefStruct directive -> fail
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (fullType: (A.fullType, Ast_c.fullType) matcher) =
- fun typa typb ->
- X.optional_qualifier_flag (fun optional_qualifier ->
- X.all_bound (A.get_inherited typa) >&&>
- match A.unwrap typa, typb with
- | A.Type(cv,ty1), ((qu,il),ty2) ->
-
- if qu.B.const && qu.B.volatile
- then
- pr2_once
- ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
-
- (* Drop out the const/volatile part that has been matched.
- * This is because a SP can contain const T v; in which case
- * later in match_t_t when we encounter a T, we must not add in
- * the environment the whole type.
- *)
-
-
- (match cv with
- (* "iso-by-absence" *)
- | None ->
- let do_stuff () =
- fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
- return (
- (A.Type(None, ty1)) +> A.rewrap typa,
- fullty2
- ))
- in
- (match optional_qualifier, qu.B.const || qu.B.volatile with
- | false, false -> do_stuff ()
- | false, true -> fail
- | true, false -> do_stuff ()
- | true, true ->
- if !Flag.show_misc
- then pr2_once "USING optional_qualifier builtin isomorphism";
- do_stuff()
- )
-
-
- | Some x ->
- (* todo: can be __const__ ? can be const & volatile so
- * should filter instead ?
- *)
- (match term x, il with
- | A.Const, [i1] when qu.B.const ->
-
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | A.Volatile, [i1] when qu.B.volatile ->
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | _ -> fail
- )
- )
-
- | A.DisjType typas, typb ->
- typas +>
- List.fold_left (fun acc typa -> acc >|+|> (fullType typa typb)) fail
-
- | A.OptType(_), _ | A.UniqueType(_), _
- -> failwith "not handling Opt/Unique on type"
- )
-
-
-(*
- * Why not (A.typeC, Ast_c.typeC) matcher ?
- * because when there is MetaType, we want that T record the whole type,
- * including the qualifier, and so this type (and the new_il function in
- * preceding function).
-*)
-
-and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
- fun ta tb ->
- X.all_bound (A.get_inherited ta) >&&>
- match A.unwrap ta, tb with
-
- (* cas general *)
- | A.MetaType(ida,keep, inherited), typb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
- X.distrf_type ida typb >>= (fun ida typb ->
- return (
- A.MetaType(ida,keep, inherited) +> A.rewrap ta,
- typb
- ))
- )
- | unwrap, (qub, typb) ->
- typeC ta typb >>= (fun ta typb ->
- return (ta, (qub, typb))
- )
-
-and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda =
- (* In ii there is a list, sometimes of length 1 or 2 or 3.
- * And even if in baseb we have a Signed Int, that does not mean
- * that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
- * something :( So for the moment when there is signed in cocci,
- * we force that there is a signed in c too (done in pattern.ml).
- *)
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
-
- (* handle some iso on type ? (cf complex C rule for possible implicit
- casting) *)
- match basea, baseb with
- | A.VoidType, B.Void
- | A.FloatType, B.FloatType (B.CFloat)
- | A.DoubleType, B.FloatType (B.CDouble) ->
- assert (signaopt = None);
- let stringa = tuple_of_list1 stringsa in
- let (ibaseb) = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType baseb, [ibaseb])
- ))
-
- | A.CharType, B.IntType B.CChar when signaopt = None ->
- let stringa = tuple_of_list1 stringsa in
- let ibaseb = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (B.IntType B.CChar), [ibaseb])
- ))
-
- | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
- let stringa = tuple_of_list1 stringsa in
- let ibaseb = tuple_of_list1 iibaseb in
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
-
- | A.ShortType, B.IntType (B.Si (_, B.CShort))
- | A.IntType, B.IntType (B.Si (_, B.CInt))
- | A.LongType, B.IntType (B.Si (_, B.CLong)) ->
- let stringa = tuple_of_list1 stringsa in
- (match iibaseb with
- | [] ->
- (* iso-by-presence ? *)
- (* when unsigned int in SP, allow have just unsigned in C ? *)
- if mcode_contain_plus (mcodekind stringa)
- then fail
- else
-
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [])
- ))
-
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
- | _ -> raise Impossible
-
- )
-
-
- | A.LongLongType, B.IntType (B.Si (_, B.CLongLong)) ->
- let (string1a,string2a) = tuple_of_list2 stringsa in
- (match iibaseb with
- [ibase1b;ibase2b] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf string1a ibase1b >>= (fun base1a ibase1b ->
- tokenf string2a ibase2b >>= (fun base2a ibase2b ->
- return (
- (rebuilda ([base1a;base2a], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibase1b;ibase2b])
- ))))
- | [] -> fail (* should something be done in this case? *)
- | _ -> raise Impossible)
-
-
- | _, B.FloatType B.CLongDouble
- ->
- pr2_once
- "warning: long double not handled by ast_cocci";
- fail
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda =
- (* In ii there is a list, sometimes of length 1 or 2 or 3.
- * And even if in baseb we have a Signed Int, that does not mean
- * that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
- * something :( So for the moment when there is signed in cocci,
- * we force that there is a signed in c too (done in pattern.ml).
- *)
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
- let match_to_type rebaseb =
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- let ibaseb = tuple_of_list1 iibaseb in
- let fta = A.rewrap basea (A.Type(None,basea)) in
- let ftb = Ast_c.nQ,(B.BaseType (rebaseb), [ibaseb]) in
- fullType fta ftb >>= (fun fta (_,tb) ->
- (match A.unwrap fta,tb with
- A.Type(_,basea), (B.BaseType baseb, ii) ->
- let ibaseb = tuple_of_list1 ii in
- return (
- (rebuilda (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )
- | _ -> failwith "not possible"))) in
-
- (* handle some iso on type ? (cf complex C rule for possible implicit
- casting) *)
- match baseb with
- | B.IntType (B.Si (_sign, B.CChar2)) ->
- match_to_type (B.IntType B.CChar)
-
- | B.IntType (B.Si (_, ty)) ->
- (match iibaseb with
- | [] -> fail (* metavariable has to match something *)
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
- | _ -> raise Impossible
-
- )
-
- | (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and (typeC: (A.typeC, Ast_c.typeC) matcher) =
- fun ta tb ->
- match A.unwrap ta, tb with
- | A.BaseType (basea,stringsa), (B.BaseType baseb, ii) ->
- simulate_signed ta basea stringsa None tb baseb ii
- (function (stringsa, signaopt) -> A.BaseType (basea,stringsa))
- | A.SignedT (signaopt, Some basea), (B.BaseType baseb, ii) ->
- (match A.unwrap basea with
- A.BaseType (basea1,strings1) ->
- simulate_signed ta basea1 strings1 (Some signaopt) tb baseb ii
- (function (strings1, Some signaopt) ->
- A.SignedT
- (signaopt,
- Some (A.rewrap basea (A.BaseType (basea1,strings1))))
- | _ -> failwith "not possible")
- | A.MetaType(ida,keep,inherited) ->
- simulate_signed_meta ta basea (Some signaopt) tb baseb ii
- (function (basea, Some signaopt) ->
- A.SignedT(signaopt,Some basea)
- | _ -> failwith "not possible")
- | _ -> failwith "not possible")
- | A.SignedT (signa,None), (B.BaseType baseb, ii) ->
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
- (match iibaseb, baseb with
- | [], B.IntType (B.Si (_sign, B.CInt)) ->
- sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
- match signaopt with
- | None -> raise Impossible
- | Some signa ->
- return (
- (A.SignedT (signa,None)) +> A.rewrap ta,
- (B.BaseType baseb, iisignbopt)
- )
- )
- | _ -> fail
- )
-
-
-
- (* todo? iso with array *)
- | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
- let (ibmult) = tuple_of_list1 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf iamult ibmult >>= (fun iamult ibmult ->
- return (
- (A.Pointer (typa, iamult)) +> A.rewrap ta,
- (B.Pointer typb, [ibmult])
- )))
-
- | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
-
- let (lpb, rpb) = tuple_of_list2 ii in
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- return (
- (A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa) +> A.rewrap ta,
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), [lpb;rpb])
- )
- )))))
-
-
-
-
-
- | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
- (B.ParenType t1, ii) ->
- let (lp1b, rp1b) = tuple_of_list2 ii in
- let (qu1b, t1b) = t1 in
- (match t1b with
- | B.Pointer t2, ii ->
- let (starb) = tuple_of_list1 ii in
- let (qu2b, t2b) = t2 in
- (match t2b with
- | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
- let (lp2b, rp2b) = tuple_of_list2 ii in
-
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
-
- fullType tya tyb >>= (fun tya tyb ->
- tokenf lp1a lp1b >>= (fun lp1a lp1b ->
- tokenf rp1a rp1b >>= (fun rp1a rp1b ->
- tokenf lp2a lp2b >>= (fun lp2a lp2b ->
- tokenf rp2a rp2b >>= (fun rp2a rp2b ->
- tokenf stara starb >>= (fun stara starb ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
-
- let t2 =
- (qu2b,
- (B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
- [lp2b;rp2b]))
- in
- let t1 =
- (qu1b,
- (B.Pointer t2, [starb]))
- in
-
- return (
- (A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
- +> A.rewrap ta,
- (B.ParenType t1, [lp1b;rp1b])
- )
- )))))))
-
-
-
- | _ -> fail
- )
- | _ -> fail
- )
-
-
-
- (* todo: handle the iso on optionnal size specifification ? *)
- | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- option expression eaopt ebopt >>= (fun eaopt ebopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- (A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
- (B.Array (ebopt, typb), [ib1;ib2])
- )))))
-
-
- (* todo: could also match a Struct that has provided a name *)
- (* This is for the case where the SmPL code contains "struct x", without
- a definition. In this case, the name field is always present.
- This case is also called from the case for A.StructUnionDef when
- a name is present in the C code. *)
- | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
- (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
- let (ib1, ib2) = tuple_of_list2 ii in
- if equal_structUnion (term sua) sub
- then
- ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
- tokenf sua ib1 >>= (fun sua ib1 ->
- return (
- (A.StructUnionName (sua, Some sa)) +> A.rewrap ta,
- (B.StructUnionName (sub, sb), [ib1;ib2])
- )))
- else fail
-
-
- | A.StructUnionDef(ty, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
-
- let (ii_sub_sb, lbb, rbb) =
- match ii with
- [iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
- | [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
- | _ -> failwith "list of length 3 or 4 expected" in
-
- let process_type =
- match (sbopt,ii_sub_sb) with
- (None,Common.Left iisub) ->
- (* the following doesn't reconstruct the complete SP code, just
- the part that matched *)
- let rec loop s =
- match A.unwrap s with
- A.Type(None,ty) ->
- (match A.unwrap ty with
- A.StructUnionName(sua, None) ->
- tokenf sua iisub >>= (fun sua iisub ->
- let ty =
- A.Type(None,
- A.StructUnionName(sua, None) +> A.rewrap ty)
- +> A.rewrap s in
- return (ty,[iisub]))
- | _ -> fail)
- | A.DisjType(disjs) ->
- disjs +>
- List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
- | _ -> fail in
- loop ty
-
- | (Some sb,Common.Right (iisub,iisb)) ->
-
- (* build a StructUnionName from a StructUnion *)
- let fake_su = B.nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) in
-
- fullType ty fake_su >>= (fun ty fake_su ->
- match fake_su with
- | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
- return (ty, [iisub; iisb])
- | _ -> raise Impossible)
- | _ -> fail in
-
- process_type
- >>= (fun ty ii_sub_sb ->
-
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
- struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
- let declsa = redots declsa undeclsa in
-
- return (
- (A.StructUnionDef(ty, lba, declsa, rba)) +> A.rewrap ta,
- (B.StructUnion (sub, sbopt, declsb),ii_sub_sb@[lbb;rbb])
- )))))
-
-
- (* todo? handle isomorphisms ? because Unsigned Int can be match on a
- * uint in the C code. But some CEs consists in renaming some types,
- * so we don't want apply isomorphisms every time.
- *)
- | A.TypeName sa, (B.TypeName (sb,typb), ii) ->
- let (isb) = tuple_of_list1 ii in
- if (term sa) =$= sb
- then
- tokenf sa isb >>= (fun sa isb ->
- return (
- (A.TypeName sa) +> A.rewrap ta,
- (B.TypeName (sb,typb), [isb])
- ))
- else fail
-
- | _, (B.TypeOfExpr e, ii) -> fail
- | _, (B.TypeOfType e, ii) -> fail
-
- | _, (B.ParenType e, ii) -> fail (* todo ?*)
- | A.EnumName(en,namea), (B.EnumName nameb, ii) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
- tokenf en ib1 >>= (fun en ib1 ->
- return (
- (A.EnumName (en, namea)) +> A.rewrap ta,
- (B.EnumName nameb, [ib1;ib2])
- )))
-
- | _, (B.Enum _, _) -> fail (* todo cocci ?*)
-
- | _,
- ((B.TypeName (_, _) | B.StructUnionName (_, _) | B.EnumName _ |
- B.StructUnion (_, _, _) |
- B.FunctionType _ | B.Array (_, _) | B.Pointer _ |
- B.BaseType _),
- _)
- -> fail
-
-
-(* todo: iso on sign, if not mentioned then free. tochange?
- * but that require to know if signed int because explicit
- * signed int, or because implicit signed int.
- *)
-
-and sign signa signb =
- match signa, signb with
- | None, None -> return (None, [])
- | Some signa, Some (signb, ib) ->
- if equal_sign (term signa) signb
- then tokenf signa ib >>= (fun signa ib ->
- return (Some signa, [ib])
- )
- else fail
- | _, _ -> fail
-
-
-and minusize_list iixs =
- iixs +> List.fold_left (fun acc ii ->
- acc >>= (fun xs ys ->
- tokenf minusizer ii >>= (fun minus ii ->
- return (minus::xs, ii::ys)
- ))) (return ([],[]))
- >>= (fun _xsminys ys ->
- return ((), List.rev ys)
- )
-
-and storage_optional_allminus allminus stoa (stob, iistob) =
- (* "iso-by-absence" for storage, and return type. *)
- X.optional_storage_flag (fun optional_storage ->
- match stoa, stob with
- | None, (stobis, inline) ->
- let do_minus () =
- if allminus
- then
- minusize_list iistob >>= (fun () iistob ->
- return (None, (stob, iistob))
- )
- else return (None, (stob, iistob))
- in
-
- (match optional_storage, stobis with
- | false, B.NoSto -> do_minus ()
- | false, _ -> fail
- | true, B.NoSto -> do_minus ()
- | true, _ ->
- if !Flag.show_misc
- then pr2_once "USING optional_storage builtin isomorphism";
- do_minus()
- )
-
- | Some x, ((stobis, inline)) ->
- if equal_storage (term x) stobis
- then
- match iistob with
- | [i1] ->
- tokenf x i1 >>= (fun x i1 ->
- return (Some x, ((stobis, inline), [i1]))
- )
- (* or if have inline ? have to do a split_storage_inline a la
- * split_signb_baseb_ii *)
- | _ -> raise Impossible
- else fail
- )
-
-
-
-
-
-and fullType_optional_allminus allminus tya retb =
- match tya with
- | None ->
- if allminus
- then
- X.distrf_type minusizer retb >>= (fun _x retb ->
- return (None, retb)
- )
-
- else return (None, retb)
- | Some tya ->
- fullType tya retb >>= (fun tya retb ->
- return (Some tya, retb)
- )
-
-
-
-(*---------------------------------------------------------------------------*)
-
-and compatible_base_type a signa b =
- let ok = return ((),()) in
-
- match a, b with
- | Type_cocci.VoidType, B.Void ->
- assert (signa = None);
- ok
- | Type_cocci.CharType, B.IntType B.CChar when signa = None ->
- ok
- | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb
- | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
- compatible_sign signa signb
- | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
- compatible_sign signa signb
- | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
- compatible_sign signa signb
- | _, B.IntType (B.Si (signb, B.CLongLong)) ->
- pr2_once "no longlong in cocci";
- fail
- | Type_cocci.FloatType, B.FloatType B.CFloat ->
- assert (signa = None);
- ok
- | Type_cocci.DoubleType, B.FloatType B.CDouble ->
- assert (signa = None);
- ok
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
- | Type_cocci.BoolType, _ -> failwith "no booltype in C"
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and compatible_base_type_meta a signa qua b ii local =
- match a, b with
- | Type_cocci.MetaType(ida,keep,inherited),
- B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb >>= fun _ _ ->
- let newb = ((qua, (B.BaseType (B.IntType B.CChar),ii)),local) in
- compatible_type a newb
- | Type_cocci.MetaType(ida,keep,inherited), B.IntType (B.Si (signb, ty)) ->
- compatible_sign signa signb >>= fun _ _ ->
- let newb =
- ((qua, (B.BaseType (B.IntType (B.Si (B.Signed, ty))),ii)),local) in
- compatible_type a newb
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-
-and compatible_type a (b,local) =
- let ok = return ((),()) in
-
- let rec loop = function
- | Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
- compatible_base_type a None b
-
- | Type_cocci.SignedT (signa,None), (qua, (B.BaseType b,ii)) ->
- compatible_base_type Type_cocci.IntType (Some signa) b
-
- | Type_cocci.SignedT (signa,Some ty), (qua, (B.BaseType b,ii)) ->
- (match ty with
- Type_cocci.BaseType ty ->
- compatible_base_type ty (Some signa) b
- | Type_cocci.MetaType(ida,keep,inherited) ->
- compatible_base_type_meta ty (Some signa) qua b ii local
- | _ -> failwith "not possible")
-
- | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
- loop (a,b)
- | Type_cocci.FunctionPointer a, _ ->
- failwith
- "TODO: function pointer type doesn't store enough information to determine compatability"
- | Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
- (* no size info for cocci *)
- loop (a,b)
- | Type_cocci.StructUnionName (sua, _, sa),
- (qub, (B.StructUnionName (sub, sb),ii)) ->
- if equal_structUnion_type_cocci sua sub && sa = sb
- then ok
- else fail
- | Type_cocci.EnumName (_, sa),
- (qub, (B.EnumName (sb),ii)) ->
- if sa = sb
- then ok
- else fail
- | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
- if sa = sb
- then ok
- else fail
-
- | Type_cocci.ConstVol (qua, a), (qub, b) ->
- if (fst qub).B.const && (fst qub).B.volatile
- then
- begin
- pr2_once ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
- fail
- end
- else
- if
- (match qua with
- | Type_cocci.Const -> (fst qub).B.const
- | Type_cocci.Volatile -> (fst qub).B.volatile
- )
- then loop (a,(Ast_c.nQ, b))
- else fail
-
- | Type_cocci.MetaType (ida,keep,inherited), typb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (A.make_mcode ida, B.MetaTypeVal typb, max_min)
- (fun () -> ok
- )
-
- (* subtil: must be after the MetaType case *)
- | a, (qub, (B.TypeName (sb,Some b), ii)) ->
- (* kind of typedef iso *)
- loop (a,b)
-
-
-
-
-
- (* for metavariables of type expression *^* *)
- | Type_cocci.Unknown , _ -> ok
-
- | (_,
- (_,
- ((
- B.TypeOfType _|B.TypeOfExpr _|B.ParenType _|
- B.EnumName _|B.StructUnion (_, _, _)|B.Enum (_, _)
- ),
- _))) -> fail
-
- | (_,
- (_,
- ((
- B.StructUnionName (_, _)|
- B.FunctionType _|
- B.Array (_, _)|B.Pointer _|B.TypeName _|
- B.BaseType _
- ),
- _))) -> fail
-
-
- in
- loop (a,b)
-
-and compatible_sign signa signb =
- let ok = return ((),()) in
- match signa, signb with
- | None, B.Signed
- | Some Type_cocci.Signed, B.Signed
- | Some Type_cocci.Unsigned, B.UnSigned
- -> ok
- | _ -> fail
-
-
-and equal_structUnion_type_cocci a b =
- match a, b with
- | Type_cocci.Struct, B.Struct -> true
- | Type_cocci.Union, B.Union -> true
- | _, (B.Struct | B.Union) -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-and inc_file (a, before_after) (b, h_rel_pos) =
-
- let rec aux_inc (ass, bss) passed =
- match ass, bss with
- | [], [] -> true
- | [A.IncDots], _ ->
- let passed = List.rev passed in
-
- (match before_after, !h_rel_pos with
- | IncludeNothing, _ -> true
- | IncludeMcodeBefore, Some x ->
- List.mem passed (x.Ast_c.first_of)
-
- | IncludeMcodeAfter, Some x ->
- List.mem passed (x.Ast_c.last_of)
-
- (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
- | _, None -> false
- )
-
- | (A.IncPath x)::xs, y::ys -> x = y && aux_inc (xs, ys) (x::passed)
- | _ -> failwith "IncDots not in last place or other pb"
-
- in
-
- match a, b with
- | A.Local ass, B.Local bss ->
- aux_inc (ass, bss) []
- | A.NonLocal ass, B.NonLocal bss ->
- aux_inc (ass, bss) []
- | _ -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-
-and (define_params: sequence ->
- (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- define_paramsbis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-(* todo? facto code with argument and parameters ? *)
-and define_paramsbis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.DPdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_define_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- define_paramsbis eas endxs >>= (fun eas endxs ->
- return (
- (A.DPdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.DPComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DPComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.DPComma ia1, ebs ->
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else
- (define_paramsbis eas ebs) (* try optional comma trick *)
-
- | (A.OptDParam _ | A.UniqueDParam _), _ ->
- failwith "handling Opt/Unique for define parameters"
-
- | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
- | A.DParam ida, (Left (idb, ii))::ebs ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DParam ida)+> A.rewrap ea :: eas,
- (Left (idb, [ib1]))::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-(*****************************************************************************)
-(* Entry points *)
-(*****************************************************************************)
-
-(* no global solution for positions here, because for a statement metavariable
-we want a MetaStmtVal, and for the others, it's not clear what we want *)
-
-let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
- fun re node ->
- let rewrap x =
- x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
- in
- X.all_bound (A.get_inherited re) >&&>
-
- rewrap (
- match A.unwrap re, F.unwrap node with
-
- (* note: the order of the clauses is important. *)
-
- | _, F.Enter | _, F.Exit | _, F.ErrorExit -> fail2()
-
- (* the metaRuleElem contains just '-' information. We dont need to add
- * stuff in the environment. If we need stuff in environment, because
- * there is a + S somewhere, then this will be done via MetaStmt, not
- * via MetaRuleElem.
- * Can match TrueNode/FalseNode/... so must be placed before those cases.
- *)
-
- | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
- let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
- (match unwrap_node with
- | F.CaseNode _
- | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
- | F.InLoopNode ->
- if X.mode = PatternMode
- then return default
- else
- if mcode_contain_plus (mcodekind mcode)
- then failwith "try add stuff on fake node"
- (* minusize or contextize a fake node is ok *)
- else return default
-
- | F.EndStatement None ->
- if X.mode = PatternMode then return default
- else
- (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
- if mcode_contain_plus (mcodekind mcode)
- then
- let fake_info = Ast_c.fakeInfo() in
- distrf distrf_node (mcodekind mcode)
- (F.EndStatement (Some fake_info))
- else return unwrap_node
- *)
- raise Todo
-
- | F.EndStatement (Some i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.MetaRuleElem (mcode,keep, inherited),
- F.EndStatement (Some i1)
- ))
-
- | F.FunHeader _ ->
- if X.mode = PatternMode then return default
- else failwith "a MetaRuleElem can't transform a headfunc"
- | _n ->
- if X.mode = PatternMode then return default
- else
- X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
- return (
- A.MetaRuleElem(mcode,keep, inherited),
- F.unwrap node
- ))
- )
-
-
- (* rene cant have found that a state containing a fake/exit/... should be
- * transformed
- * TODO: and F.Fake ?
- *)
- | _, F.EndStatement _ | _, F.CaseNode _
- | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
- | _, F.InLoopNode
- -> fail2()
-
- (* really ? diff between pattern.ml and transformation.ml *)
- | _, F.Fake -> fail2()
-
-
- (* cas general: a Meta can match everything. It matches only
- * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
- * So can't have been called in transform.
- *)
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
-
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
- (* todo: should not happen in transform mode *)
-
- (match Control_flow_c.extract_fullstatement node with
- | Some stb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_stmt stb) in
- X.envf keep inherited (ida, Ast_c.MetaStmtVal stb, max_min)
- (fun () ->
- (* no need tag ida, we can't be called in transform-mode *)
- return (
- A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
- unwrap_node
- )
- )
- | None -> fail
- )
-
- (* not me?: *)
- | A.MetaStmtList _, _ ->
- failwith "not handling MetaStmtList"
-
- | A.TopExp ea, F.DefineExpr eb ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.TopExp ea,
- F.DefineExpr eb
- ))
-
- | A.TopExp ea, F.DefineType eb ->
- (match A.unwrap ea with
- A.TypeExp(ft) ->
- fullType ft eb >>= (fun ft eb ->
- return (
- A.TopExp (A.rewrap ea (A.TypeExp(ft))),
- F.DefineType eb
- ))
- | _ -> fail)
-
-
-
- (* It is important to put this case before the one that fails because
- * of the lack of the counter part of a C construct in SmPL (for instance
- * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
- * yet certain constructs, those constructs may contain expression
- * that we still want and can transform.
- *)
-
- | A.Exp exp, nodeb ->
-
- (* kind of iso, initialisation vs affectation *)
- let node =
- match A.unwrap exp, nodeb with
- | A.Assignment (ea, op, eb, true), F.Decl decl ->
- initialisation_to_affectation decl +> F.rewrap node
- | _ -> node
- in
-
-
- (* Now keep fullstatement inside the control flow node,
- * so that can then get in a MetaStmtVar the fullstatement to later
- * pp back when the S is in a +. But that means that
- * Exp will match an Ifnode even if there is no such exp
- * inside the condition of the Ifnode (because the exp may
- * be deeper, in the then branch). So have to not visit
- * all inside a node anymore.
- *
- * update: j'ai choisi d'accrocher au noeud du CFG Ã la
- * fois le fullstatement et le partialstatement et appeler le
- * visiteur que sur le partialstatement.
- *)
- let expfn =
- match Ast_cocci.get_pos re with
- | None -> expression
- | Some pos ->
- (fun ea eb ->
- let (max,min) =
- Lib_parsing_c.max_min_by_pos (Lib_parsing_c.ii_of_expr eb) in
- let keep = Type_cocci.Unitary in
- let inherited = false in
- let max_min _ = failwith "no pos" in
- X.envf keep inherited (pos, B.MetaPosVal (min,max), max_min)
- (fun () ->
- expression ea eb
- )
- )
- in
- X.cocciExp expfn exp node >>= (fun exp node ->
- return (
- A.Exp exp,
- F.unwrap node
- )
- )
-
- | A.Ty ty, nodeb ->
- X.cocciTy fullType ty node >>= (fun ty node ->
- return (
- A.Ty ty,
- F.unwrap node
- )
- )
-
- | A.TopInit init, nodeb ->
- X.cocciInit initialiser init node >>= (fun init node ->
- return (
- A.TopInit init,
- F.unwrap node
- )
- )
-
-
- | A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
- F.FunHeader ({B.f_name = idb;
- f_type = (retb, (paramsb, (isvaargs, iidotsb)));
- f_storage = stob;
- f_attr = attrs;
- f_body = body;
- f_old_c_style = oldstyle;
- }, ii) ->
- assert (null body);
-
- if oldstyle <> None
- then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
-
-
- (* fninfoa records the order in which the SP specified the various
- information, but this isn't taken into account in the matching.
- Could this be a problem for transformation? *)
- let stoa =
- match
- List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
- with [A.FStorage(s)] -> Some s | _ -> None in
- let tya =
- match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
- with [A.FType(t)] -> Some t | _ -> None in
-
- (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
- with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
-
- (match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
- with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
-
- (match ii with
- | iidb::ioparenb::icparenb::iifakestart::iistob ->
-
- (* maybe important to put ident as the first tokens to transform.
- * It's related to transform_proto. So don't change order
- * between the >>=.
- *)
- ident LocalFunction ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- tokenf oparen ioparenb >>= (fun oparen ioparenb ->
- tokenf cparen icparenb >>= (fun cparen icparenb ->
- parameters (seqstyle paramsa)
- (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- storage_optional_allminus allminus
- stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
- (
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
- if allminus
- then minusize_list iidotsb
- else return ((),iidotsb)
- ) >>= (fun () iidotsb ->
-
- fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
-
- let fninfoa =
- (match stoa with Some st -> [A.FStorage st] | None -> []) ++
- (match tya with Some t -> [A.FType t] | None -> [])
-
- in
-
- return (
- A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
- paramsa,cparen),
- F.FunHeader ({B.f_name = idb;
- f_type = (retb, (paramsb, (isvaargs, iidotsb)));
- f_storage = stob;
- f_attr = attrs;
- f_body = body;
- f_old_c_style = oldstyle; (* TODO *)
- },
- iidb::ioparenb::icparenb::iifakestart::iistob)
- )
- ))))))))
- | _ -> raise Impossible
- )
-
-
-
-
-
-
- | A.Decl (mckstart,allminus,decla), F.Decl declb ->
- declaration (mckstart,allminus,decla) declb >>=
- (fun (mckstart,allminus,decla) declb ->
- return (
- A.Decl (mckstart,allminus,decla),
- F.Decl declb
- ))
-
-
- | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.SeqStart mcode,
- F.SeqStart (st, level, i1)
- ))
-
- | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.SeqEnd mcode,
- F.SeqEnd (level, i1)
- ))
-
- | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- A.ExprStatement (ea, ia1),
- F.ExprStatement (st, (Some eb, [ib1]))
- )
- ))
-
-
- | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- A.IfHeader (ia1, ia2, ea, ia3),
- F.IfHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | A.Else ia, F.Else ib ->
- tokenf ia ib >>= (fun ia ib ->
- return (A.Else ia, F.Else ib)
- )
-
- | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- A.WhileHeader (ia1, ia2, ea, ia3),
- F.WhileHeader (st, (eb, [ib1;ib2;ib3]))
- )))))
-
- | A.DoHeader ia, F.DoHeader (st, ib) ->
- tokenf ia ib >>= (fun ia ib ->
- return (
- A.DoHeader ia,
- F.DoHeader (st, ib)
- ))
- | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
- let (ib1, ib2, ib3, ib4) = tuple_of_list4 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- return (
- A.WhileTail (ia1,ia2,ea,ia3,ia4),
- F.DoWhileTail (eb, [ib1;ib2;ib3;ib4])
- ))))))
- | A.IteratorHeader (ia1, ia2, eas, ia3), F.MacroIterHeader (st, ((s,ebs),ii))
- ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
-
- ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- A.IteratorHeader (ia1, ia2, eas, ia3),
- F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
- )))))
-
-
-
- | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,ib3s), (eb2opt,ib4s), (eb3opt,ib4vide)), ii))
- ->
- assert (null ib4vide);
- let (ib1, ib2, ib5) = tuple_of_list3 ii in
- let ib3 = tuple_of_list1 ib3s in
- let ib4 = tuple_of_list1 ib4s in
-
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- tokenf ia5 ib5 >>= (fun ia5 ib5 ->
- option expression ea1opt eb1opt >>= (fun ea1opt eb1opt ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- option expression ea3opt eb3opt >>= (fun ea3opt eb3opt ->
- return (
- A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,[ib3]), (eb2opt,[ib4]), (eb3opt,[])),
- [ib1;ib2;ib5]))
-
- )))))))))
-
-
- | A.SwitchHeader(ia1,ia2,ea,ia3), F.SwitchHeader (st, (eb,ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.SwitchHeader(ia1,ia2,ea,ia3),
- F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Break (ia1, ia2),
- F.Break (st, ((),[ib1;ib2]))
- )))
-
- | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Continue (ia1, ia2),
- F.Continue (st, ((),[ib1;ib2]))
- )))
-
- | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Return (ia1, ia2),
- F.Return (st, ((),[ib1;ib2]))
- )))
-
- | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.ReturnExpr (ia1, ea, ia2),
- F.ReturnExpr (st, (eb, [ib1;ib2]))
- ))))
-
-
-
- | A.Include(incla,filea),
- F.Include {B.i_include = (fileb, ii);
- B.i_rel_pos = h_rel_pos;
- B.i_is_in_ifdef = inifdef;
- B.i_content = copt;
- } ->
- assert (copt = None);
-
- let include_requirment =
- match mcodekind incla, mcodekind filea with
- | A.CONTEXT (_, A.BEFORE _), _ ->
- IncludeMcodeBefore
- | _, A.CONTEXT (_, A.AFTER _) ->
- IncludeMcodeAfter
- | _ ->
- IncludeNothing
- in
-
- let (inclb, iifileb) = tuple_of_list2 ii in
- if inc_file (term filea, include_requirment) (fileb, h_rel_pos)
- then
- tokenf incla inclb >>= (fun incla inclb ->
- tokenf filea iifileb >>= (fun filea iifileb ->
- return (
- A.Include(incla, filea),
- F.Include {B.i_include = (fileb, [inclb;iifileb]);
- B.i_rel_pos = h_rel_pos;
- B.i_is_in_ifdef = inifdef;
- B.i_content = copt;
- }
- )))
- else fail
-
-
-
- | A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
- let (defineb, iidb, ieol) = tuple_of_list3 ii in
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- tokenf definea defineb >>= (fun definea defineb ->
- (match A.unwrap params, defkind with
- | A.NoParams, B.DefineVar ->
- return (
- A.NoParams +> A.rewrap params,
- B.DefineVar
- )
- | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
- let (lpb, rpb) = tuple_of_list2 ii in
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
-
- define_params (seqstyle eas) (A.undots eas) ebs >>=
- (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- A.DParams (lpa,eas,rpa) +> A.rewrap params,
- B.DefineFunc (ebs,[lpb;rpb])
- )
- )))
- | _ -> fail
- ) >>= (fun params defkind ->
- return (
- A.DefineHeader (definea, ida, params),
- F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
- ))
- ))
-
-
- | A.Default(def,colon), F.Default (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf def ib1 >>= (fun def ib1 ->
- tokenf colon ib2 >>= (fun colon ib2 ->
- return (
- A.Default(def,colon),
- F.Default (st, ((),[ib1;ib2]))
- )))
-
-
-
- | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf case ib1 >>= (fun case ib1 ->
- expression ea eb >>= (fun ea eb ->
- tokenf colon ib2 >>= (fun colon ib2 ->
- return (
- A.Case(case,ea,colon),
- F.Case (st, (eb,[ib1;ib2]))
- ))))
-
- (* only occurs in the predicates generated by asttomember *)
- | A.DisjRuleElem eas, _ ->
- (eas +>
- List.fold_left (fun acc ea -> acc >|+|> (rule_elem_node ea node)) fail)
- >>= (fun ea eb -> return (A.unwrap ea,F.unwrap eb))
-
- | _, F.ExprStatement (_, (None, ii)) -> fail (* happen ? *)
-
- | A.Label(id,dd), F.Label (st,(s,ii)) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- let (string_of_id,rebuild) =
- match A.unwrap id with
- A.Id(s) -> (s,function s -> A.rewrap id (A.Id(s)))
- | _ -> failwith "labels with metavariables not supported" in
- if (term string_of_id) =$= s
- then
- tokenf string_of_id ib1 >>= (fun string_of_id ib1 ->
- tokenf dd ib2 >>= (fun dd ib2 ->
- return (
- A.Label(rebuild string_of_id,dd),
- F.Label (st,(s,[ib1;ib2]))
- )))
- else fail
-
- | A.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- tokenf goto ib1 >>= (fun goto ib1 ->
- ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
- tokenf sem ib3 >>= (fun sem ib3 ->
- return(
- A.Goto(goto,id,sem),
- F.Goto (st,(s,[ib1;ib2;ib3]))
- ))))
-
- (* have not a counter part in coccinelle, for the moment *)
- (* todo?: print a warning at least ? *)
- | _, F.CaseRange _
- | _, F.Asm _
- | _, F.MacroTop _
- -> fail2()
-
- | _, (F.IfdefEndif _|F.IfdefElse _|F.IfdefHeader _)
- -> fail2 ()
-
- | _,
- (F.MacroStmt (_, _)| F.DefineDoWhileZeroHeader _| F.EndNode|F.TopNode)
- -> fail
- | _,
- (F.Label (_, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
- F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
- F.DefineType _|F.DefineExpr _|F.DefineTodo|
- F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|F.MacroIterHeader (_, _)|
- F.SwitchHeader (_, _)|F.ForHeader (_, _)|F.DoWhileTail _|F.DoHeader (_, _)|
- F.WhileHeader (_, _)|F.Else _|F.IfHeader (_, _)|
- F.SeqEnd (_, _)|F.SeqStart (_, _, _)|
- F.Decl _|F.FunHeader _)
- -> fail
-
-
- )
-end
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-module A = Ast_cocci
-module B = Ast_c
-
-module F = Control_flow_c
-
-module Flag = Flag_matcher
-
-(*****************************************************************************)
-(* Wrappers *)
-(*****************************************************************************)
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-type sequence = Ordered | Unordered
-
-let seqstyle eas =
- match A.unwrap eas with
- | A.DOTS _ -> Ordered
- | A.CIRCLES _ -> Unordered
- | A.STARS _ -> failwith "not handling stars"
-
-let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
- A.rewrap eas (
- match A.unwrap eas with
- | A.DOTS _ -> A.DOTS easundots
- | A.CIRCLES _ -> A.CIRCLES easundots
- | A.STARS _ -> A.STARS easundots
- )
-
-
-let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
- fun ibs ->
- ibs +> List.exists (fun (ib, icomma) ->
- match B.unwrap ib with
- | B.InitDesignators _
- | B.InitFieldOld _
- | B.InitIndexOld _
- -> true
- | B.InitExpr _
- | B.InitList _
- -> false
- )
-
-(* For the #include <linux/...> in the .cocci, need to find where is
- * the '+' attached to this element, to later find the first concrete
- * #include <linux/xxx.h> or last one in the serie of #includes in the
- * .c.
- *)
-type include_requirement =
- | IncludeMcodeBefore
- | IncludeMcodeAfter
- | IncludeNothing
-
-
-
-(* todo? put in semantic_c.ml *)
-type info_ident =
- | Function
- | LocalFunction (* entails Function *)
- | DontKnow
-
-
-let term mc = A.unwrap_mcode mc
-let mcodekind mc = A.get_mcodekind mc
-
-
-let mcode_contain_plus = function
- | A.CONTEXT (_,A.NOTHING) -> false
- | A.CONTEXT _ -> true
- | A.MINUS (_,[]) -> false
- | A.MINUS (_,x::xs) -> true
- | A.PLUS -> raise Impossible
-
-let mcode_simple_minus = function
- | A.MINUS (_,[]) -> true
- | _ -> false
-
-
-(* In transformation.ml sometime I build some mcodekind myself and
- * julia has put None for the pos. But there is no possible raise
- * NoMatch in those cases because it is for the minusall trick or for
- * the distribute, so either have to build those pos, in fact a range,
- * because for the distribute have to erase a fullType with one
- * mcodekind, or add an argument to tag_with_mck such as "safe" that
- * don't do the check_pos. Hence this DontCarePos constructor. *)
-
-let minusizer =
- ("fake","fake"),
- {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
- (A.MINUS(A.DontCarePos, [])),
- A.NoMetaPos
-
-let generalize_mcode ia =
- let (s1, i, mck, pos) = ia in
- let new_mck =
- match mck with
- | A.PLUS -> raise Impossible
- | A.CONTEXT (A.NoPos,x) ->
- A.CONTEXT (A.DontCarePos,x)
- | A.MINUS (A.NoPos,x) ->
- A.MINUS (A.DontCarePos,x)
-
- | A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
- | A.MINUS ((A.FixPos _|A.DontCarePos), _)
- ->
- raise Impossible
- in
- (s1, i, new_mck, pos)
-
-
-
-(*---------------------------------------------------------------------------*)
-
-(* 0x0 is equivalent to 0, value format isomorphism *)
-let equal_c_int s1 s2 =
- try
- int_of_string s1 = int_of_string s2
- with Failure("int_of_string") ->
- s1 =$= s2
-
-
-
-(*---------------------------------------------------------------------------*)
-(* Normally A should reuse some types of Ast_c, so those
- * functions should not exist.
- *
- * update: but now Ast_c depends on A, so can't make too
- * A depends on Ast_c, so have to stay with those equal_xxx
- * functions.
- *)
-
-let equal_unaryOp a b =
- match a, b with
- | A.GetRef , B.GetRef -> true
- | A.DeRef , B.DeRef -> true
- | A.UnPlus , B.UnPlus -> true
- | A.UnMinus , B.UnMinus -> true
- | A.Tilde , B.Tilde -> true
- | A.Not , B.Not -> true
- | _, B.GetRefLabel -> false (* todo cocci? *)
- | _, (B.Not|B.Tilde|B.UnMinus|B.UnPlus|B.DeRef|B.GetRef) -> false
-
-
-
-let equal_arithOp a b =
- match a, b with
- | A.Plus , B.Plus -> true
- | A.Minus , B.Minus -> true
- | A.Mul , B.Mul -> true
- | A.Div , B.Div -> true
- | A.Mod , B.Mod -> true
- | A.DecLeft , B.DecLeft -> true
- | A.DecRight , B.DecRight -> true
- | A.And , B.And -> true
- | A.Or , B.Or -> true
- | A.Xor , B.Xor -> true
- | _, (B.Xor|B.Or|B.And|B.DecRight|B.DecLeft|B.Mod|B.Div|B.Mul|B.Minus|B.Plus)
- -> false
-
-let equal_logicalOp a b =
- match a, b with
- | A.Inf , B.Inf -> true
- | A.Sup , B.Sup -> true
- | A.InfEq , B.InfEq -> true
- | A.SupEq , B.SupEq -> true
- | A.Eq , B.Eq -> true
- | A.NotEq , B.NotEq -> true
- | A.AndLog , B.AndLog -> true
- | A.OrLog , B.OrLog -> true
- | _, (B.OrLog|B.AndLog|B.NotEq|B.Eq|B.SupEq|B.InfEq|B.Sup|B.Inf)
- -> false
-
-let equal_assignOp a b =
- match a, b with
- | A.SimpleAssign, B.SimpleAssign -> true
- | A.OpAssign a, B.OpAssign b -> equal_arithOp a b
- | _, (B.OpAssign _|B.SimpleAssign) -> false
-
-let equal_fixOp a b =
- match a, b with
- | A.Dec, B.Dec -> true
- | A.Inc, B.Inc -> true
- | _, (B.Inc|B.Dec) -> false
-
-let equal_binaryOp a b =
- match a, b with
- | A.Arith a, B.Arith b -> equal_arithOp a b
- | A.Logical a, B.Logical b -> equal_logicalOp a b
- | _, (B.Logical _ | B.Arith _) -> false
-
-let equal_structUnion a b =
- match a, b with
- | A.Struct, B.Struct -> true
- | A.Union, B.Union -> true
- | _, (B.Struct|B.Union) -> false
-
-let equal_sign a b =
- match a, b with
- | A.Signed, B.Signed -> true
- | A.Unsigned, B.UnSigned -> true
- | _, (B.UnSigned|B.Signed) -> false
-
-let equal_storage a b =
- match a, b with
- | A.Static , B.Sto B.Static
- | A.Auto , B.Sto B.Auto
- | A.Register , B.Sto B.Register
- | A.Extern , B.Sto B.Extern
- -> true
- | _, (B.NoSto | B.StoTypedef) -> false
- | _, (B.Sto (B.Register|B.Static|B.Auto|B.Extern)) -> false
-
-
-(*---------------------------------------------------------------------------*)
-
-let equal_metavarval valu valu' =
- match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
- | Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
- | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
- (* do something more ? *)
- a =$= b
-
- (* al_expr before comparing !!! and accept when they match.
- * Note that here we have Astc._expression, so it is a match
- * modulo isomorphism (there is no metavariable involved here,
- * just isomorphisms). => TODO call isomorphism_c_c instead of
- * =*=. Maybe would be easier to transform ast_c in ast_cocci
- * and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
- Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
- | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
- Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
-
- | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
- Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
- | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
- Lib_parsing_c.al_init a =*= Lib_parsing_c.al_init b
- | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
- (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
- C_vs_c.eq_type a b
-
- | Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
-
- | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
- Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
- | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
- Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
-
- | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
- Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
-
- | Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
- List.exists
- (function (fla,cea,posa1,posa2) ->
- List.exists
- (function (flb,ceb,posb1,posb2) ->
- fla = flb && cea = ceb &&
- Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
- l2)
- l1
-
- | (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
- |B.MetaTypeVal _ |B.MetaInitVal _
- |B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
- |B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
- ), _
- -> raise Impossible
-
-
-(*---------------------------------------------------------------------------*)
-(* could put in ast_c.ml, next to the split/unsplit_comma *)
-let split_signb_baseb_ii (baseb, ii) =
- let iis = ii +> List.map (fun info -> (B.str_of_info info), info) in
- match baseb, iis with
-
- | B.Void, ["void",i1] -> None, [i1]
-
- | B.FloatType (B.CFloat),["float",i1] -> None, [i1]
- | B.FloatType (B.CDouble),["double",i1] -> None, [i1]
- | B.FloatType (B.CLongDouble),["long",i1;"double",i2] -> None,[i1;i2]
-
- | B.IntType (B.CChar), ["char",i1] -> None, [i1]
-
-
- | B.IntType (B.Si (sign, base)), xs ->
- (match sign, base, xs with
- | B.Signed, B.CChar2, ["signed",i1;"char",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CChar2, ["unsigned",i1;"char",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CShort, ["short",i1] ->
- None, [i1]
- | B.Signed, B.CShort, ["signed",i1;"short",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2] ->
- Some (B.UnSigned, i1), [i2]
- | B.Signed, B.CShort, ["short",i1;"int",i2] ->
- None, [i1;i2]
-
- | B.Signed, B.CInt, ["int",i1] ->
- None, [i1]
- | B.Signed, B.CInt, ["signed",i1;"int",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CInt, ["unsigned",i1;"int",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CInt, ["signed",i1;] ->
- Some (B.Signed, i1), []
- | B.UnSigned, B.CInt, ["unsigned",i1;] ->
- Some (B.UnSigned, i1), []
-
- | B.Signed, B.CLong, ["long",i1] ->
- None, [i1]
- | B.Signed, B.CLong, ["long",i1;"int",i2] ->
- None, [i1;i2]
- | B.Signed, B.CLong, ["signed",i1;"long",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CLong, ["unsigned",i1;"long",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CLongLong, ["long",i1;"long",i2] -> None, [i1;i2]
- | B.Signed, B.CLongLong, ["signed",i1;"long",i2;"long",i3] ->
- Some (B.Signed, i1), [i2;i3]
- | B.UnSigned, B.CLongLong, ["unsigned",i1;"long",i2;"long",i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2; "int", i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
-
- | _ -> failwith "strange type1, maybe because of weird order"
- )
- | _ -> failwith "strange type2, maybe because of weird order"
-
-(*---------------------------------------------------------------------------*)
-
-let rec unsplit_icomma xs =
- match xs with
- | [] -> []
- | x::y::xs ->
- (match A.unwrap y with
- | A.IComma mcode ->
- (x, y)::unsplit_icomma xs
- | _ -> failwith "wrong ast_cocci in initializer"
- )
- | _ ->
- failwith ("wrong ast_cocci in initializer, should have pair " ^
- "number of Icomma")
-
-
-
-let resplit_initialiser ibs iicomma =
- match iicomma, ibs with
- | [], [] -> []
- | [], _ ->
- failwith "should have a iicomma, do you generate fakeInfo in parser?"
- | _, [] ->
- failwith "shouldn't have a iicomma"
- | [iicomma], x::xs ->
- let elems = List.map fst (x::xs) in
- let commas = List.map snd (x::xs) +> List.flatten in
- let commas = commas @ [iicomma] in
- zip elems commas
- | _ -> raise Impossible
-
-
-
-let rec split_icomma xs =
- match xs with
- | [] -> []
- | (x,y)::xs -> x::y::split_icomma xs
-
-let rec unsplit_initialiser ibs_unsplit =
- match ibs_unsplit with
- | [] -> [], [] (* empty iicomma *)
- | (x, commax)::xs ->
- let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
- (x, [])::xs, lastcomma
-
-and unsplit_initialiser_bis comma_before = function
- | [] -> [], [comma_before]
- | (x, commax)::xs ->
- let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
- (x, [comma_before])::xs, lastcomma
-
-
-
-
-(*---------------------------------------------------------------------------*)
-(* coupling: same in type_annotater_c.ml *)
-let structdef_to_struct_name ty =
- match ty with
- | qu, (B.StructUnion (su, sopt, fields), iis) ->
- (match sopt,iis with
- | Some s , [i1;i2;i3;i4] ->
- qu, (B.StructUnionName (su, s), [i1;i2])
- | None, _ ->
- ty
-
- | x -> raise Impossible
- )
- | _ -> raise Impossible
-
-(*---------------------------------------------------------------------------*)
-let initialisation_to_affectation decl =
- match decl with
- | B.MacroDecl _ -> F.Decl decl
- | B.DeclList (xs, iis) ->
-
- (* todo?: should not do that if the variable is an array cos
- * will have x[] = , mais de toute facon ca sera pas un InitExp
- *)
- (match xs with
- | [] -> raise Impossible
- | [x] ->
- let ({B.v_namei = var;
- B.v_type = returnType;
- B.v_storage = storage;
- B.v_local = local},
- iisep) = x in
-
- (match var with
- | Some ((s, ini), iis::iini) ->
- (match ini with
- | Some (B.InitExpr e, ii_empty2) ->
- let local =
- match local with
- Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
- | Ast_c.LocalDecl -> Ast_c.LocalVar (iis.Ast_c.pinfo) in
-
- let typ =
- ref (Some ((Lib_parsing_c.al_type returnType),local),
- Ast_c.NotTest) in
- let id = (B.Ident s, typ),[iis] in
- F.DefineExpr
- ((B.Assignment (id, B.SimpleAssign, e),
- Ast_c.noType()), iini)
- | _ -> F.Decl decl
- )
- | _ -> F.Decl decl
- )
- | x::xs ->
- pr2_once "TODO: initialisation_to_affectation for multi vars";
- (* todo? do a fold_left and generate 'x = a, y = b' etc, use
- * the Sequence expression operator of C and make an
- * ExprStatement from that.
- *)
- F.Decl decl
- )
-
-
-
-
-
-(*****************************************************************************)
-(* Functor parameter combinators *)
-(*****************************************************************************)
-(* monad like stuff
- * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
- *
- * version0: was not tagging the SP, so just tag the C
- * val (>>=):
- * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
- * val return : 'b -> tin -> 'b tout
- * val fail : tin -> 'b tout
- *
- * version1: now also tag the SP so return a ('a * 'b)
- *)
-
-type mode = PatternMode | TransformMode
-
-module type PARAM =
- sig
- type tin
- type 'x tout
-
-
- type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
-
- val mode : mode
-
- val (>>=):
- (tin -> ('a * 'b) tout) ->
- ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
- (tin -> ('c * 'd) tout)
-
- val return : ('a * 'b) -> tin -> ('a *'b) tout
- val fail : tin -> ('a * 'b) tout
-
- val (>||>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>|+|>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>&&>) : (tin -> bool) -> (tin -> 'x tout) -> (tin -> 'x tout)
-
- val tokenf : ('a A.mcode, B.info) matcher
- val tokenf_mck : (A.mcodekind, B.info) matcher
-
- val distrf_e :
- (A.meta_name A.mcode, B.expression) matcher
- val distrf_args :
- (A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
- val distrf_type :
- (A.meta_name A.mcode, Ast_c.fullType) matcher
- val distrf_params :
- (A.meta_name A.mcode,
- (Ast_c.parameterType, Ast_c.il) either list) matcher
- val distrf_param :
- (A.meta_name A.mcode, Ast_c.parameterType) matcher
- val distrf_ini :
- (A.meta_name A.mcode, Ast_c.initialiser) matcher
- val distrf_node :
- (A.meta_name A.mcode, Control_flow_c.node) matcher
-
- val distrf_define_params :
- (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
- matcher
-
- val distrf_struct_fields :
- (A.meta_name A.mcode, B.field list) matcher
-
- val distrf_cst :
- (A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
-
- val cocciExp :
- (A.expression, B.expression) matcher -> (A.expression, F.node) matcher
-
- val cocciExpExp :
- (A.expression, B.expression) matcher ->
- (A.expression, B.expression) matcher
-
- val cocciTy :
- (A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
-
- val cocciInit :
- (A.initialiser, B.initialiser) matcher -> (A.initialiser, F.node) matcher
-
- val envf :
- A.keep_binding -> A.inherited ->
- A.meta_name A.mcode * Ast_c.metavar_binding_kind *
- (unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val check_constraints :
- ('a, 'b) matcher -> 'a list -> 'b ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val all_bound : A.meta_name list -> (tin -> bool)
-
- val optional_storage_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
-
-
- end
-
-(*****************************************************************************)
-(* Functor code, "Cocci vs C" *)
-(*****************************************************************************)
-
-module COCCI_VS_C =
- functor (X : PARAM) ->
-struct
-
-type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
-
-let (>>=) = X.(>>=)
-let return = X.return
-let fail = X.fail
-
-let (>||>) = X.(>||>)
-let (>|+|>) = X.(>|+|>)
-let (>&&>) = X.(>&&>)
-
-let tokenf = X.tokenf
-
-(* should be raise Impossible when called from transformation.ml *)
-let fail2 () =
- match X.mode with
- | PatternMode -> fail
- | TransformMode -> raise Impossible
-
-
-let (option: ('a,'b) matcher -> ('a option,'b option) matcher)= fun f t1 t2 ->
- match (t1,t2) with
- | (Some t1, Some t2) ->
- f t1 t2 >>= (fun t1 t2 ->
- return (Some t1, Some t2)
- )
- | (None, None) -> return (None, None)
- | _ -> fail
-
-(* Dots are sometimes used as metavariables, since like metavariables they
-can match other things. But they no longer have the same type. Perhaps these
-functions could be avoided by introducing an appropriate level of polymorphism,
-but I don't know how to declare polymorphism across functors *)
-let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
-let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
-
-(*---------------------------------------------------------------------------*)
-(* toc:
- * - expression
- * - ident
- * - arguments
- * - parameters
- * - declaration
- * - initialisers
- * - type
- * - node
- *)
-
-(*---------------------------------------------------------------------------*)
-let rec (expression: (A.expression, Ast_c.expression) matcher) =
- fun ea eb ->
- X.all_bound (A.get_inherited ea) >&&>
- let wa x = A.rewrap ea x in
- match A.unwrap ea, eb with
-
- (* general case: a MetaExpr can match everything *)
- | A.MetaExpr (ida,constraints,keep,opttypa,form,inherited),
- (((expr, opttypb), ii) as expb) ->
-
- (* old: before have a MetaConst. Now we factorize and use 'form' to
- * differentiate between different cases *)
- let rec matches_id = function
- B.Ident(c) -> true
- | B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
- | _ -> false in
- let form_ok =
- match (form,expr) with
- (A.ANY,_) -> true
- | (A.CONST,e) ->
- let rec matches = function
- B.Constant(c) -> true
- | B.Ident idb when idb =~ "^[A-Z_][A-Z_0-9]*$" ->
- pr2_once ("warning: I consider " ^ idb ^ " as a constant");
- true
- | B.Cast(ty,e) -> matches (B.unwrap_expr e)
- | B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
- | B.SizeOfExpr(exp) -> true
- | B.SizeOfType(ty) -> true
- | _ -> false in
- matches e
- | (A.LocalID,e) ->
- (matches_id e) &&
- (match !opttypb with
- (Some (_,Ast_c.LocalVar _),_) -> true
- | _ -> false)
- | (A.ID,e) -> matches_id e in
-
- if form_ok
- then
- (let (opttypb,_testb) = !opttypb in
- match opttypa, opttypb with
- | None, _ -> return ((),())
- | Some _, None ->
- pr2_once ("Missing type information. Certainly a pb in " ^
- "annotate_typer.ml");
- fail
-
- | Some tas, Some tb ->
- tas +> List.fold_left (fun acc ta ->
- acc >|+|> compatible_type ta tb) fail
- ) >>=
- (fun () () ->
- X.check_constraints expression constraints eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>= (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )))
- else fail
-
- (* old:
- * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
- * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
- *
- * but bug! because if have not tagged SP, then transform without doing
- * any checks. Hopefully now have tagged SP technique.
- *)
-
-
- (* old:
- * | A.Edots _, _ -> raise Impossible.
- *
- * In fact now can also have the Edots inside normal expression, not
- * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
- *)
- | A.Edots (mcode, None), expb ->
- X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
- return (
- A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
- expb
- ))
-
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
-
- | A.Ident ida, ((B.Ident idb, typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- return (
- ((A.Ident ida)) +> wa,
- ((B.Ident idb, typ),[ib1])
- ))
-
-
-
-
- | A.MetaErr _, _ -> failwith "not handling MetaErr"
-
- (* todo?: handle some isomorphisms in int/float ? can have different
- * format : 1l can match a 1.
- *
- * todo: normally string can contain some metavar too, so should
- * recurse on the string
- *)
- | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
- (* for everything except the String case where can have multi elems *)
- let do1 () =
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
- ((B.Constant (ib), typ),[ib1])
- ))
- in
- (match term ia1, ib with
- | A.Int x, B.Int y ->
- X.value_format_flag (fun use_value_equivalence ->
- if use_value_equivalence
- then
- if equal_c_int x y
- then do1()
- else fail
- else
- if x =$= y
- then do1()
- else fail
- )
- | A.Char x, B.Char (y,_) when x =$= y (* todo: use kind ? *)
- -> do1()
- | A.Float x, B.Float (y,_) when x =$= y (* todo: use floatType ? *)
- -> do1()
-
- | A.String sa, B.String (sb,_kind) when sa =$= sb ->
- (match ii with
- | [ib1] ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
- ((B.Constant (ib), typ),[ib1])
- ))
- | _ -> fail (* multi string, not handled *)
- )
-
- | _, B.MultiString _ -> (* todo cocci? *) fail
- | _, (B.String _ | B.Float _ | B.Char _ | B.Int _) -> fail
- )
-
-
- | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
- (* todo: do special case to allow IdMetaFunc, cos doing the
- * recursive call will be too late, match_ident will not have the
- * info whether it was a function. todo: but how detect when do
- * x.field = f; how know that f is a Func ? By having computed
- * some information before the matching!
- *
- * Allow match with FunCall containing types. Now ast_cocci allow
- * type in parameter, and morover ast_cocci allow f(...) and those
- * ... could match type.
- *)
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- ((A.FunCall (ea, ia1, eas, ia2)) +> wa,
- ((B.FunCall (eb, ebs),typ), [ib1;ib2])
- ))))))
-
-
-
-
- | A.Assignment (ea1, opa, ea2, simple),
- ((B.Assignment (eb1, opb, eb2), typ),ii) ->
- let (opbi) = tuple_of_list1 ii in
- if equal_assignOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
- ((B.Assignment (eb1, opb, eb2), typ), [opbi])
- ))))
- else fail
-
- | A.CondExpr(ea1,ia1,ea2opt,ia2,ea3),((B.CondExpr(eb1,eb2opt,eb3),typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- expression ea3 eb3 >>= (fun ea3 eb3 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.CondExpr(ea1,ia1,ea2opt,ia2,ea3))) +> wa,
- ((B.CondExpr (eb1, eb2opt, eb3),typ), [ib1;ib2])
- ))))))
-
- (* todo?: handle some isomorphisms here ? *)
- | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_fixOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Postfix (ea, opa))) +> wa,
- ((B.Postfix (eb, opb), typ),[opbi])
- )))
- else fail
-
-
- | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_fixOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Infix (ea, opa))) +> wa,
- ((B.Infix (eb, opb), typ),[opbi])
- )))
- else fail
-
- | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_unaryOp (term opa) opb
- then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Unary (ea, opa))) +> wa,
- ((B.Unary (eb, opb), typ),[opbi])
- )))
- else fail
-
- | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
- let opbi = tuple_of_list1 ii in
- if equal_binaryOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Binary (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))
- else fail
-
- | A.Nested (ea1, opa, ea2), eb ->
- let rec loop eb =
- (if A.get_test_exp ea1 && not (Ast_c.is_test eb) then fail
- else expression ea1 eb) >|+|>
- (match eb with
- ((B.Binary (eb1, opb, eb2), typ),ii)
- when equal_binaryOp (term opa) opb ->
- let opbi = tuple_of_list1 ii in
- let left_to_right =
- (expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let right_to_left =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- expression ea1 eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let in_left =
- (loop eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- let in_right =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- loop eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
- | _ -> fail) in
- loop eb
-
- (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
- | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.ArrayAccess (ea1, ia1, ea2, ia2))) +> wa,
- ((B.ArrayAccess (eb1, eb2),typ), [ib1;ib2])
- )))))
-
- (* todo?: handle some isomorphisms here ? *)
- | A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
- return (
- ((A.RecordAccess (ea, ia1, ida))) +> wa,
- ((B.RecordAccess (eb, idb), typ), [ib1;ib2])
- ))))
-
-
-
- | A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
- return (
- ((A.RecordPtAccess (ea, ia1, ida))) +> wa,
- ((B.RecordPtAccess (eb, idb), typ), [ib1;ib2])
- ))))
-
-
- (* todo?: handle some isomorphisms here ?
- * todo?: do some iso-by-absence on cast ?
- * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
- *)
-
- | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.Cast (ia1, typa, ia2, ea))) +> wa,
- ((B.Cast (typb, eb),typ),[ib1;ib2])
- )))))
-
- | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.SizeOfExpr (ia1, ea))) +> wa,
- ((B.SizeOfExpr (eb), typ),[ib1])
- )))
-
- | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- ((A.SizeOfType (ia1, ia2, typa, ia3))) +> wa,
- ((B.SizeOfType (typb),typ),[ib1;ib2;ib3])
- )))))
-
-
- (* todo? iso ? allow all the combinations ? *)
- | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- ((A.Paren (ia1, ea, ia2))) +> wa,
- ((B.ParenExpr (eb), typ), [ib1;ib2])
- ))))
-
- | A.NestExpr(exps,None,true), eb ->
- (match A.unwrap exps with
- A.DOTS [exp] ->
- X.cocciExpExp expression exp eb >>= (fun exp eb ->
- return (
- (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
- eb
- )
- )
- | _ ->
- failwith
- "for nestexpr, only handling the case with dots and only one exp")
-
- | A.NestExpr _, _ ->
- failwith "only handling multi and no when code in a nest expr"
-
- (* only in arg lists or in define body *)
- | A.TypeExp _, _ -> fail
-
- (* only in arg lists *)
- | A.MetaExprList _, _
- | A.EComma _, _
- | A.Ecircles _, _
- | A.Estars _, _
- ->
- raise Impossible
-
- | A.DisjExpr eas, eb ->
- eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
-
- | A.UniqueExp _,_ | A.OptExp _,_ ->
- failwith "not handling Opt/Unique/Multi on expr"
-
- (* Because of Exp cant put a raise Impossible; have to put a fail *)
-
- (* have not a counter part in coccinelle, for the moment *)
- | _, ((B.Sequence _,_),_)
- | _, ((B.StatementExpr _,_),_)
- | _, ((B.Constructor _,_),_)
- -> fail
-
-
- | _,
- (((B.Cast (_, _)|B.ParenExpr _|B.SizeOfType _|B.SizeOfExpr _|
- B.RecordPtAccess (_, _)|
- B.RecordAccess (_, _)|B.ArrayAccess (_, _)|
- B.Binary (_, _, _)|B.Unary (_, _)|
- B.Infix (_, _)|B.Postfix (_, _)|
- B.Assignment (_, _, _)|B.CondExpr (_, _, _)|
- B.FunCall (_, _)|B.Constant _|B.Ident _),
- _),_)
- -> fail
-
-
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
- fun infoidb ida ((idb, iib) as ib) ->
- X.all_bound (A.get_inherited ida) >&&>
- match A.unwrap ida with
- | A.Id sa ->
- if (term sa) =$= idb then
- tokenf sa iib >>= (fun sa iib ->
- return (
- ((A.Id sa)) +> A.rewrap ida,
- (idb, iib)
- ))
- else fail
-
-
- | A.MetaId(mida,constraints,keep,inherited) ->
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- (* use drop_pos for ids so that the pos is not added a second time in
- the call to tokenf *)
- X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
- (idb, iib)
- )))
- ))
-
- | A.MetaFunc(mida,constraints,keep,inherited) ->
- let is_function _ =
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
- (idb, iib)
- ))
- )) in
- (match infoidb with
- | LocalFunction | Function -> is_function()
- | DontKnow ->
- failwith "MetaFunc, need more semantic info about id"
- (* the following implementation could possibly be useful, if one
- follows the convention that a macro is always in capital letters
- and that a macro is not a function.
- (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
- )
-
- | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
- (match infoidb with
- | LocalFunction ->
- X.check_constraints (ident infoidb) constraints ib
- (fun () ->
- let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
- X.envf keep inherited
- (A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaLocalFunc(mida,constraints,keep,inherited)))
- +> A.rewrap ida,
- (idb, iib)
- ))
- ))
- | Function -> fail
- | DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
- )
-
- | A.OptIdent _ | A.UniqueIdent _ ->
- failwith "not handling Opt/Unique for ident"
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (arguments: sequence ->
- (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-(* because '...' can match nothing, need to take care when have
- * ', ...' or '...,' as in f(..., X, Y, ...). It must match
- * f(1,2) for instance.
- * So I have added special cases such as (if startxs = []) and code
- * in the Ecomma matching rule.
- *
- * old: Must do some try, for instance when f(...,X,Y,...) have to
- * test the transfo for all the combinaitions and if multiple transfo
- * possible ? pb ? => the type is to return a expression option ? use
- * some combinators to help ?
- * update: with the tag-SP approach, no more a problem.
- *)
-
-and arguments_bis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Edots (mcode, optexpr), ys ->
- (* todo: if optexpr, then a WHEN and so may have to filter yys *)
- if optexpr <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (* allow '...', and maybe its associated ',' to match nothing.
- * for the associated ',' see below how we handle the EComma
- * to match nothing.
- *)
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (* subtil: we dont want the '...' to match until the
- * comma. cf -test pb_params_iso. We would get at
- * "already tagged" error.
- * this is because both f (... x, ...) and f (..., x, ...)
- * would match a f(x,3) with our "optional-comma" strategy.
- *)
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_args (dots2metavar mcode) startxs
- )
- )
- >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.EComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.EComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
- | A.EComma ia1, ebs ->
- (* allow ',' to maching nothing. optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else arguments_bis eas ebs
-
- | A.MetaExprList(ida,leninfo,keep,inherited),ys ->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- | Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_args startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaExprListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_args ida (Ast_c.split_comma startxs')
- )
- >>= (fun ida startxs ->
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaExprList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- )
- )) fail
-
-
- | _unwrapx, (Left eb)::ebs ->
- argument ea eb >>= (fun ea eb ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (ea::eas, Left eb::ebs)
- ))
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-and argument arga argb =
- X.all_bound (A.get_inherited arga) >&&>
- match A.unwrap arga, argb with
- | A.TypeExp tya, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
-
- if b || sopt <> None
- then
- (* failwith "the argument have a storage and ast_cocci does not have"*)
- fail
- else
- fullType tya tyb >>= (fun tya tyb ->
- return (
- (A.TypeExp tya) +> A.rewrap arga,
- (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
- ))
-
- | A.TypeExp tya, _ -> fail
- | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
- | _, Left argb ->
- expression arga argb >>= (fun arga argb ->
- return (arga, Left argb)
- )
- | _, Right (B.ArgAction y) -> fail
-
-
-(* ------------------------------------------------------------------------- *)
-(* todo? facto code with argument ? *)
-and (parameters: sequence ->
- (A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
- matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-
-and parameters_bis eas ebs =
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- (* the management of positions is inlined into each case, because
- sometimes there is a Param and sometimes a ParamList *)
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Pdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on"*)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Pdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.PComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.PComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.PComma ia1, ebs ->
- (* try optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else parameters_bis eas ebs
-
-
- | A.MetaParamList(ida,leninfo,keep,inherited),ys->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "I have no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_params startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaParamListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_params ida (Ast_c.split_comma startxs')
- ) >>= (fun ida startxs ->
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaParamList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- ))
- ) fail
-
-
- | A.VoidParam ta, ys ->
- (match eas, ebs with
- | [], [Left eb] ->
- let ((hasreg, idbopt, tb), ii_b_s) = eb in
- if idbopt = None && null ii_b_s
- then
- match tb with
- | (qub, (B.BaseType B.Void,_)) ->
- fullType ta tb >>= (fun ta tb ->
- return (
- [(A.VoidParam ta) +> A.rewrap ea],
- [Left ((hasreg, idbopt, tb), ii_b_s)]
- ))
- | _ -> fail
- else fail
- | _ -> fail
- )
-
- | (A.OptParam _ | A.UniqueParam _), _ ->
- failwith "handling Opt/Unique for Param"
-
- | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
-
- | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
- (* todo: use quaopt, hasreg ? *)
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
- X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
- X.distrf_param ida eb
- ) >>= (fun ida eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
- (Left eb)::ebs
- )))
-
-
- | A.Param (typa, idaopt), (Left eb)::ebs ->
- (*this should succeed if the C code has a name, and fail otherwise*)
- parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
- (Left eb)::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-
-
-and parameter = fun (idaopt, typa) ((hasreg, idbopt, typb), ii_b_s) ->
- fullType typa typb >>= (fun typa typb ->
- match idaopt, Ast_c.split_register_param (hasreg, idbopt, ii_b_s) with
- | Some ida, Left (idb, iihasreg, iidb) ->
- (* todo: if minus on ida, should also minus the iihasreg ? *)
- ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
- return (
- (Some ida, typa),
- ((hasreg, Some idb, typb), iihasreg++[iidb])
- ))
-
- | None, Right iihasreg ->
- return (
- (None, typa),
- ((hasreg, None, typb), iihasreg)
- )
-
-
- (* why handle this case ? because of transform_proto ? we may not
- * have an ident in the proto.
- * If have some plus on ida ? do nothing about ida ?
- *)
- (* not anymore !!! now that julia is handling the proto.
- | _, Right iihasreg ->
- return (
- (idaopt, typa),
- ((hasreg, None, typb), iihasreg)
- )
- *)
-
- | Some _, Right _ -> fail
- | None, Left _ -> fail
- )
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
- fun (mckstart, allminus, decla) declb ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
- * de toutes les declarations qui sont au debut d'un fonction et
- * commencer le reste du match au premier statement. Alors, ca matche
- * n'importe quelle declaration. On n'a pas besoin d'ajouter
- * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
- *
- * When the SP want to remove the whole function, the minus is not
- * on the MetaDecl but on the MetaRuleElem. So there should
- * be no transform of MetaDecl, just matching are allowed.
- *)
-
- | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
- (* todo: should not happen in transform mode *)
- return ((mckstart, allminus, decla), declb)
-
-
-
- | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
- onedecl allminus decla (var,iiptvirgb,iisto) >>=
- (fun decla (var,iiptvirgb,iisto)->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))
-
- | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
- if X.mode = PatternMode
- then
- xs +> List.fold_left (fun acc var ->
- acc >||> (
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- onedecl allminus decla (var, iiptvirgb, iisto) >>=
- (fun decla (var, iiptvirgb, iisto) ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))))
- fail
- else
- failwith "More that one variable in decl. Have to split to transform."
-
- | A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
- let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
- (match ii with
- | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
- (iisb,lpb,rpb,iiendb, iifakestart,iisto)
- | _ -> raise Impossible
- ) in
- (if allminus
- then minusize_list iistob
- else return ((), iistob)
- ) >>= (fun () iistob ->
-
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- ident DontKnow sa (sb, iisb) >>= (fun sa (sb, iisb) ->
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- tokenf enda iiendb >>= (fun enda iiendb ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
-
- return (
- (mckstart, allminus,
- (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
- (B.MacroDecl ((sb,ebs),
- [iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
- ))))))))
-
- | _, (B.MacroDecl _ |B.DeclList _) -> fail
-
-
-
-and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* kind of typedef iso, we must unfold, it's for the case
- * T { }; that we want to match against typedef struct { } xx_t;
- *)
- | A.TyDecl (tya0, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- (match A.unwrap tya0, typb0 with
- | A.Type(cv1,tya1), ((qu,il),typb1) ->
-
- (match A.unwrap tya1, typb1 with
- | A.StructUnionDef(tya2, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
-
- let (iisub, iisbopt, lbb, rbb) =
- match sbopt with
- | None ->
- let (iisub, lbb, rbb) = tuple_of_list3 ii in
- (iisub, [], lbb, rbb)
- | Some s ->
- pr2 (sprintf
- "warning: both a typedef (%s) and struct name introduction (%s)"
- idb s
- );
- pr2 "warning: I will consider only the typedef";
- let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
- (iisub, [iisb], lbb, rbb)
- in
- let structnameb =
- structdef_to_struct_name
- (Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
- in
- let fake_typeb =
- Ast_c.nQ,((B.TypeName (idb, Some
- (Lib_parsing_c.al_type structnameb))), [iidb])
- in
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
- struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
- let declsa = redots declsa undeclsa in
-
- (match A.unwrap tya2 with
- | A.Type(cv3, tya3) ->
- (match A.unwrap tya3 with
- | A.MetaType(ida,keep, inherited) ->
-
- fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
- let tya1 =
- A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1 in
- let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
-
- let typb1 = B.StructUnion (sub,sbopt, declsb),
- [iisub] @ iisbopt @ [lbb;rbb] in
- let typb0 = ((qu, il), typb1) in
-
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
-
- | A.StructUnionName(sua, sa) ->
-
- fullType tya2 structnameb >>= (fun tya2 structnameb ->
-
- let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
- in
- let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
- match structnameb with
- | _nQ, (B.StructUnionName (sub, s), [iisub;iisbopt]) ->
-
- let typb1 = B.StructUnion (sub,sbopt, declsb),
- [iisub;iisbopt;lbb;rbb] in
- let typb0 = ((qu, il), typb1) in
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb0;
- B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
- | _ -> raise Impossible
- )
- | _ -> fail
- )))))
- | _ -> fail
- )
- | _ -> fail
- )
-
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
-
-
-
- (* could handle iso here but handled in standard.iso *)
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- return (
- (A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb,None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg),
- iiptvirgb,iistob)
- )))))
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg)
- ->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf eqa iieqb >>= (fun eqa iieqb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg),
- iiptvirgb,iistob)
- )))))))
-
- (* do iso-by-absence here ? allow typedecl and var ? *)
- | A.TyDecl (typa, ptvirga),
- ({B.v_namei = None; B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg) ->
-
- if stob = (B.NoSto, false)
- then
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- return (
- (A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = None;
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = local;
- B.v_attr = attrs;
- }, iivirg), iiptvirgb, iistob)
- )))
- else fail
-
-
- | A.Typedef (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = (B.StoTypedef,inline);
- B.v_local = local;
- B.v_attr = attrs;
- },iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- (match iistob with
- | [iitypedef] ->
- tokenf stoa iitypedef >>= (fun stoa iitypedef ->
- return (stoa, [iitypedef])
- )
- | _ -> failwith "wierd, have both typedef and inline or nothing";
- ) >>= (fun stoa iistob ->
- (match A.unwrap ida with
- | A.MetaType(_,_,_) ->
-
- let fake_typeb =
- Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
- in
- fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
- return (ida, (idb, iidb))
- | _ -> raise Impossible
- )
-
- | A.TypeName sa ->
- if (term sa) =$= idb
- then
- tokenf sa iidb >>= (fun sa iidb ->
- return (
- (A.TypeName sa) +> A.rewrap ida,
- (idb, iidb)
- ))
- else fail
- | _ -> raise Impossible
-
- ) >>= (fun ida (idb, iidb) ->
- return (
- (A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = (B.StoTypedef,inline);
- B.v_local = local;
- B.v_attr = attrs;
- },
- iivirg),
- iiptvirgb, iistob)
- )
- ))))
-
-
- | _, ({B.v_namei = None;}, _) ->
- (* old: failwith "no variable in this declaration, wierd" *)
- fail
-
-
-
- | A.DisjDecl declas, declb ->
- declas +> List.fold_left (fun acc decla ->
- acc >|+|>
- (* (declaration (mckstart, allminus, decla) declb) *)
- (onedecl allminus decla (declb,iiptvirgb, iistob))
- ) fail
-
-
-
- (* only in struct type decls *)
- | A.Ddots(dots,whencode), _ ->
- raise Impossible
-
- | A.OptDecl _, _ | A.UniqueDecl _, _ ->
- failwith "not handling Opt/Unique Decl"
-
- | _, ({B.v_namei=Some _}, _)
- -> fail
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-
-and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
- X.all_bound (A.get_inherited ia) >&&>
- match (A.unwrap ia,ib) with
-
- | (A.MetaInit(ida,keep,inherited), ib) ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_ini ib) in
- X.envf keep inherited (ida, Ast_c.MetaInitVal ib, max_min)
- (fun () ->
- X.distrf_ini ida ib >>= (fun ida ib ->
- return (
- A.MetaInit (ida,keep,inherited) +> A.rewrap ia,
- ib
- ))
- )
-
- | (A.InitExpr expa, ib) ->
- (match A.unwrap expa, ib with
- | A.Edots (mcode, None), ib ->
- X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
- return (
- A.InitExpr
- (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
- +> A.rewrap ia,
- ib
- ))
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
- | _, (B.InitExpr expb, ii) ->
- assert (null ii);
- expression expa expb >>= (fun expa expb ->
- return (
- (A.InitExpr expa) +> A.rewrap ia,
- (B.InitExpr expb, ii)
- ))
- | _ -> fail
- )
-
- | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
- (match ii with
- | ib1::ib2::iicommaopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
- return (
- (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
- (B.InitList ibs, ib1::ib2::iicommaopt)
- ))))
-
- | _ -> raise Impossible
- )
-
- | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
- failwith "TODO: not handling whencode in initialisers"
-
-
- | (A.InitGccExt (designatorsa, ia2, inia),
- (B.InitDesignators (designatorsb, inib), ii2))->
-
- let iieq = tuple_of_list1 ii2 in
-
- tokenf ia2 iieq >>= (fun ia2 iieq ->
- designators designatorsa designatorsb >>=
- (fun designatorsa designatorsb ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccExt (designatorsa, ia2, inia)) +> A.rewrap ia,
- (B.InitDesignators (designatorsb, inib), [iieq])
- ))))
-
-
-
-
- | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
- (match ii with
- | [iidb;iicolon] ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- initialiser inia inib >>= (fun inia inib ->
- tokenf ia1 iicolon >>= (fun ia1 iicolon ->
- return (
- (A.InitGccName (ida, ia1, inia)) +> A.rewrap ia,
- (B.InitFieldOld (idb, inib), [iidb;iicolon])
- ))))
- | _ -> fail
- )
-
-
-
- | A.IComma(comma), _ ->
- raise Impossible
-
- | A.UniqueIni _,_ | A.OptIni _,_ ->
- failwith "not handling Opt/Unique on initialisers"
-
- | _, (B.InitIndexOld (_, _), _) -> fail
- | _, (B.InitFieldOld (_, _), _) -> fail
-
- | _, ((B.InitDesignators (_, _)|B.InitList _|B.InitExpr _), _)
- -> fail
-
-and designators dla dlb =
- match (dla,dlb) with
- ([],[]) -> return ([], [])
- | ([],_) | (_,[]) -> fail
- | (da::dla,db::dlb) ->
- designator da db >>= (fun da db ->
- designators dla dlb >>= (fun dla dlb ->
- return (da::dla, db::dlb)))
-
-and designator da db =
- match (da,db) with
- (A.DesignatorField (ia1, ida), (B.DesignatorField idb,ii1)) ->
-
- let (iidot, iidb) = tuple_of_list2 ii1 in
- tokenf ia1 iidot >>= (fun ia1 iidot ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- return (
- A.DesignatorField (ia1, ida),
- (B.DesignatorField idb, [iidot;iidb])
- )))
-
- | (A.DesignatorIndex (ia1,ea,ia2), (B.DesignatorIndex eb, ii1)) ->
-
- let (ib1, ib2) = tuple_of_list2 ii1 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.DesignatorIndex (ia1,ea,ia2),
- (B.DesignatorIndex eb, [ib1;ib2])
- ))))
-
- | (A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
- (B.DesignatorRange (e1b, e2b), ii1)) ->
-
- let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression e1a e1b >>= (fun e1a e1b ->
- expression e2a e2b >>= (fun e2a e2b ->
- return (
- A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
- (B.DesignatorRange (e1b, e2b), [ib1;ib2;ib3])
- ))))))
- | (_, ((B.DesignatorField _|B.DesignatorIndex _|B.DesignatorRange _), _)) ->
- fail
-
-
-and initialisers = fun ias (ibs, iicomma) ->
- let ias_unsplit = unsplit_icomma ias in
- let ibs_split = resplit_initialiser ibs iicomma in
-
- let f =
- if need_unordered_initialisers ibs
- then initialisers_unordered2
- else initialisers_ordered2
- in
- f ias_unsplit ibs_split >>=
- (fun ias_unsplit ibs_split ->
- return (
- split_icomma ias_unsplit,
- unsplit_initialiser ibs_split
- )
- )
-
-(* todo: one day julia will reput a IDots *)
-and initialisers_ordered2 = fun ias ibs ->
- match ias, ibs with
- | [], [] -> return ([], [])
- | (x, xcomma)::xs, (y, commay)::ys ->
- (match A.unwrap xcomma with
- | A.IComma commax ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- initialisers_ordered2 xs ys >>= (fun xs ys ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
- (y, commay)::ys
- )
- )))
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- | _ -> fail
-
-
-
-and initialisers_unordered2 = fun ias ibs ->
-
- match ias, ibs with
- | [], ys -> return ([], ys)
- | (x,xcomma)::xs, ys ->
-
- let permut = Common.uncons_permut_lazy ys in
- permut +> List.fold_left (fun acc ((e, pos), rest) ->
- acc >||>
- (
- (match A.unwrap xcomma, e with
- | A.IComma commax, (y, commay) ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma),
- (y, commay))
- )
- )
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- >>= (fun x e ->
- let rest = Lazy.force rest in
- initialisers_unordered2 xs rest >>= (fun xs rest ->
- return (
- x::xs,
- Common.insert_elem_pos (e, pos) rest
- ))))
- ) fail
-
-
-(* ------------------------------------------------------------------------- *)
-and (struct_fields: (A.declaration list, B.field list) matcher) =
- fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Ddots (mcode, optwhen), ys ->
- if optwhen <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
-
- X.distrf_struct_fields (dots2metavar mcode) startxs
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- struct_fields eas endxs >>= (fun eas endxs ->
- return (
- (A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
- | _unwrapx, eb::ebs ->
- struct_field ea eb >>= (fun ea eb ->
- struct_fields eas ebs >>= (fun eas ebs ->
- return (ea::eas, eb::ebs)
- ))
-
- | _unwrapx, [] -> fail
- )
-
-and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
- let (xfield, iifield) = fb in
-
- match xfield with
- | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
-
- let iiptvirgb = tuple_of_list1 iiptvirg in
-
- (match onefield_multivars with
- | [] -> raise Impossible
- | [onevar,iivirg] ->
- assert (null iivirg);
- (match onevar with
- | B.BitField (sopt, typb, expr), ii ->
- pr2_once "warning: bitfield not handled by ast_cocci";
- fail
- | B.Simple (None, typb), ii ->
- pr2_once "warning: unamed struct field not handled by ast_cocci";
- fail
- | B.Simple (Some idb, typb), ii ->
- let (iidb) = tuple_of_list1 ii in
-
- (* build a declaration from a struct field *)
- let allminus = false in
- let iisto = [] in
- let stob = B.NoSto, false in
- let fake_var =
- ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- B.v_local = Ast_c.NotLocalDecl;
- B.v_attr = Ast_c.noattr;
- },
- iivirg)
- in
- onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
- (fun fa (var,iiptvirgb,iisto) ->
-
- match fake_var with
- | ({B.v_namei = Some ((idb, None),[iidb]);
- B.v_type = typb;
- B.v_storage = stob;
- }, iivirg) ->
- let onevar = B.Simple (Some idb, typb), [iidb] in
-
- return (
- (fa),
- ((B.DeclarationField
- (B.FieldDeclList ([onevar, iivirg], [iiptvirgb]))),
- iifield)
- )
- | _ -> raise Impossible
- )
- )
-
- | x::y::xs ->
- pr2_once "PB: More that one variable in decl. Have to split";
- fail
- )
- | B.EmptyField ->
- let _iiptvirgb = tuple_of_list1 iifield in
- fail
-
- | B.MacroStructDeclTodo -> fail
- | B.CppDirectiveStruct directive -> fail
- | B.IfdefStruct directive -> fail
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (fullType: (A.fullType, Ast_c.fullType) matcher) =
- fun typa typb ->
- X.optional_qualifier_flag (fun optional_qualifier ->
- X.all_bound (A.get_inherited typa) >&&>
- match A.unwrap typa, typb with
- | A.Type(cv,ty1), ((qu,il),ty2) ->
-
- if qu.B.const && qu.B.volatile
- then
- pr2_once
- ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
-
- (* Drop out the const/volatile part that has been matched.
- * This is because a SP can contain const T v; in which case
- * later in match_t_t when we encounter a T, we must not add in
- * the environment the whole type.
- *)
-
-
- (match cv with
- (* "iso-by-absence" *)
- | None ->
- let do_stuff () =
- fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
- return (
- (A.Type(None, ty1)) +> A.rewrap typa,
- fullty2
- ))
- in
- (match optional_qualifier, qu.B.const || qu.B.volatile with
- | false, false -> do_stuff ()
- | false, true -> fail
- | true, false -> do_stuff ()
- | true, true ->
- if !Flag.show_misc
- then pr2_once "USING optional_qualifier builtin isomorphism";
- do_stuff()
- )
-
-
- | Some x ->
- (* todo: can be __const__ ? can be const & volatile so
- * should filter instead ?
- *)
- (match term x, il with
- | A.Const, [i1] when qu.B.const ->
-
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | A.Volatile, [i1] when qu.B.volatile ->
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | _ -> fail
- )
- )
-
- | A.DisjType typas, typb ->
- typas +>
- List.fold_left (fun acc typa -> acc >|+|> (fullType typa typb)) fail
-
- | A.OptType(_), _ | A.UniqueType(_), _
- -> failwith "not handling Opt/Unique on type"
- )
-
-
-(*
- * Why not (A.typeC, Ast_c.typeC) matcher ?
- * because when there is MetaType, we want that T record the whole type,
- * including the qualifier, and so this type (and the new_il function in
- * preceding function).
-*)
-
-and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
- fun ta tb ->
- X.all_bound (A.get_inherited ta) >&&>
- match A.unwrap ta, tb with
-
- (* cas general *)
- | A.MetaType(ida,keep, inherited), typb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
- X.distrf_type ida typb >>= (fun ida typb ->
- return (
- A.MetaType(ida,keep, inherited) +> A.rewrap ta,
- typb
- ))
- )
- | unwrap, (qub, typb) ->
- typeC ta typb >>= (fun ta typb ->
- return (ta, (qub, typb))
- )
-
-and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda =
- (* In ii there is a list, sometimes of length 1 or 2 or 3.
- * And even if in baseb we have a Signed Int, that does not mean
- * that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
- * something :( So for the moment when there is signed in cocci,
- * we force that there is a signed in c too (done in pattern.ml).
- *)
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
-
- (* handle some iso on type ? (cf complex C rule for possible implicit
- casting) *)
- match basea, baseb with
- | A.VoidType, B.Void
- | A.FloatType, B.FloatType (B.CFloat)
- | A.DoubleType, B.FloatType (B.CDouble) ->
- assert (signaopt = None);
- let stringa = tuple_of_list1 stringsa in
- let (ibaseb) = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType baseb, [ibaseb])
- ))
-
- | A.CharType, B.IntType B.CChar when signaopt = None ->
- let stringa = tuple_of_list1 stringsa in
- let ibaseb = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (B.IntType B.CChar), [ibaseb])
- ))
-
- | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
- let stringa = tuple_of_list1 stringsa in
- let ibaseb = tuple_of_list1 iibaseb in
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
-
- | A.ShortType, B.IntType (B.Si (_, B.CShort))
- | A.IntType, B.IntType (B.Si (_, B.CInt))
- | A.LongType, B.IntType (B.Si (_, B.CLong)) ->
- let stringa = tuple_of_list1 stringsa in
- (match iibaseb with
- | [] ->
- (* iso-by-presence ? *)
- (* when unsigned int in SP, allow have just unsigned in C ? *)
- if mcode_contain_plus (mcodekind stringa)
- then fail
- else
-
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [])
- ))
-
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
- return (
- (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
- | _ -> raise Impossible
-
- )
-
-
- | A.LongLongType, B.IntType (B.Si (_, B.CLongLong)) ->
- let (string1a,string2a) = tuple_of_list2 stringsa in
- (match iibaseb with
- [ibase1b;ibase2b] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf string1a ibase1b >>= (fun base1a ibase1b ->
- tokenf string2a ibase2b >>= (fun base2a ibase2b ->
- return (
- (rebuilda ([base1a;base2a], signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibase1b;ibase2b])
- ))))
- | [] -> fail (* should something be done in this case? *)
- | _ -> raise Impossible)
-
-
- | _, B.FloatType B.CLongDouble
- ->
- pr2_once
- "warning: long double not handled by ast_cocci";
- fail
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda =
- (* In ii there is a list, sometimes of length 1 or 2 or 3.
- * And even if in baseb we have a Signed Int, that does not mean
- * that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
- * something :( So for the moment when there is signed in cocci,
- * we force that there is a signed in c too (done in pattern.ml).
- *)
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
- let match_to_type rebaseb =
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- let ibaseb = tuple_of_list1 iibaseb in
- let fta = A.rewrap basea (A.Type(None,basea)) in
- let ftb = Ast_c.nQ,(B.BaseType (rebaseb), [ibaseb]) in
- fullType fta ftb >>= (fun fta (_,tb) ->
- (match A.unwrap fta,tb with
- A.Type(_,basea), (B.BaseType baseb, ii) ->
- let ibaseb = tuple_of_list1 ii in
- return (
- (rebuilda (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )
- | _ -> failwith "not possible"))) in
-
- (* handle some iso on type ? (cf complex C rule for possible implicit
- casting) *)
- match baseb with
- | B.IntType (B.Si (_sign, B.CChar2)) ->
- match_to_type (B.IntType B.CChar)
-
- | B.IntType (B.Si (_, ty)) ->
- (match iibaseb with
- | [] -> fail (* metavariable has to match something *)
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
- | _ -> raise Impossible
-
- )
-
- | (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and (typeC: (A.typeC, Ast_c.typeC) matcher) =
- fun ta tb ->
- match A.unwrap ta, tb with
- | A.BaseType (basea,stringsa), (B.BaseType baseb, ii) ->
- simulate_signed ta basea stringsa None tb baseb ii
- (function (stringsa, signaopt) -> A.BaseType (basea,stringsa))
- | A.SignedT (signaopt, Some basea), (B.BaseType baseb, ii) ->
- (match A.unwrap basea with
- A.BaseType (basea1,strings1) ->
- simulate_signed ta basea1 strings1 (Some signaopt) tb baseb ii
- (function (strings1, Some signaopt) ->
- A.SignedT
- (signaopt,
- Some (A.rewrap basea (A.BaseType (basea1,strings1))))
- | _ -> failwith "not possible")
- | A.MetaType(ida,keep,inherited) ->
- simulate_signed_meta ta basea (Some signaopt) tb baseb ii
- (function (basea, Some signaopt) ->
- A.SignedT(signaopt,Some basea)
- | _ -> failwith "not possible")
- | _ -> failwith "not possible")
- | A.SignedT (signa,None), (B.BaseType baseb, ii) ->
- let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
- (match iibaseb, baseb with
- | [], B.IntType (B.Si (_sign, B.CInt)) ->
- sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
- match signaopt with
- | None -> raise Impossible
- | Some signa ->
- return (
- (A.SignedT (signa,None)) +> A.rewrap ta,
- (B.BaseType baseb, iisignbopt)
- )
- )
- | _ -> fail
- )
-
-
-
- (* todo? iso with array *)
- | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
- let (ibmult) = tuple_of_list1 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf iamult ibmult >>= (fun iamult ibmult ->
- return (
- (A.Pointer (typa, iamult)) +> A.rewrap ta,
- (B.Pointer typb, [ibmult])
- )))
-
- | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
-
- let (lpb, rpb) = tuple_of_list2 ii in
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- return (
- (A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa) +> A.rewrap ta,
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), [lpb;rpb])
- )
- )))))
-
-
-
-
-
- | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
- (B.ParenType t1, ii) ->
- let (lp1b, rp1b) = tuple_of_list2 ii in
- let (qu1b, t1b) = t1 in
- (match t1b with
- | B.Pointer t2, ii ->
- let (starb) = tuple_of_list1 ii in
- let (qu2b, t2b) = t2 in
- (match t2b with
- | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
- let (lp2b, rp2b) = tuple_of_list2 ii in
-
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
-
- fullType tya tyb >>= (fun tya tyb ->
- tokenf lp1a lp1b >>= (fun lp1a lp1b ->
- tokenf rp1a rp1b >>= (fun rp1a rp1b ->
- tokenf lp2a lp2b >>= (fun lp2a lp2b ->
- tokenf rp2a rp2b >>= (fun rp2a rp2b ->
- tokenf stara starb >>= (fun stara starb ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
-
- let t2 =
- (qu2b,
- (B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
- [lp2b;rp2b]))
- in
- let t1 =
- (qu1b,
- (B.Pointer t2, [starb]))
- in
-
- return (
- (A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
- +> A.rewrap ta,
- (B.ParenType t1, [lp1b;rp1b])
- )
- )))))))
-
-
-
- | _ -> fail
- )
- | _ -> fail
- )
-
-
-
- (* todo: handle the iso on optionnal size specifification ? *)
- | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- option expression eaopt ebopt >>= (fun eaopt ebopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- (A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
- (B.Array (ebopt, typb), [ib1;ib2])
- )))))
-
-
- (* todo: could also match a Struct that has provided a name *)
- (* This is for the case where the SmPL code contains "struct x", without
- a definition. In this case, the name field is always present.
- This case is also called from the case for A.StructUnionDef when
- a name is present in the C code. *)
- | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
- (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
- let (ib1, ib2) = tuple_of_list2 ii in
- if equal_structUnion (term sua) sub
- then
- ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
- tokenf sua ib1 >>= (fun sua ib1 ->
- return (
- (A.StructUnionName (sua, Some sa)) +> A.rewrap ta,
- (B.StructUnionName (sub, sb), [ib1;ib2])
- )))
- else fail
-
-
- | A.StructUnionDef(ty, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
-
- let (ii_sub_sb, lbb, rbb) =
- match ii with
- [iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
- | [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
- | _ -> failwith "list of length 3 or 4 expected" in
-
- let process_type =
- match (sbopt,ii_sub_sb) with
- (None,Common.Left iisub) ->
- (* the following doesn't reconstruct the complete SP code, just
- the part that matched *)
- let rec loop s =
- match A.unwrap s with
- A.Type(None,ty) ->
- (match A.unwrap ty with
- A.StructUnionName(sua, None) ->
- tokenf sua iisub >>= (fun sua iisub ->
- let ty =
- A.Type(None,
- A.StructUnionName(sua, None) +> A.rewrap ty)
- +> A.rewrap s in
- return (ty,[iisub]))
- | _ -> fail)
- | A.DisjType(disjs) ->
- disjs +>
- List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
- | _ -> fail in
- loop ty
-
- | (Some sb,Common.Right (iisub,iisb)) ->
-
- (* build a StructUnionName from a StructUnion *)
- let fake_su = B.nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) in
-
- fullType ty fake_su >>= (fun ty fake_su ->
- match fake_su with
- | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
- return (ty, [iisub; iisb])
- | _ -> raise Impossible)
- | _ -> fail in
-
- process_type
- >>= (fun ty ii_sub_sb ->
-
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
- struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
- let declsa = redots declsa undeclsa in
-
- return (
- (A.StructUnionDef(ty, lba, declsa, rba)) +> A.rewrap ta,
- (B.StructUnion (sub, sbopt, declsb),ii_sub_sb@[lbb;rbb])
- )))))
-
-
- (* todo? handle isomorphisms ? because Unsigned Int can be match on a
- * uint in the C code. But some CEs consists in renaming some types,
- * so we don't want apply isomorphisms every time.
- *)
- | A.TypeName sa, (B.TypeName (sb,typb), ii) ->
- let (isb) = tuple_of_list1 ii in
- if (term sa) =$= sb
- then
- tokenf sa isb >>= (fun sa isb ->
- return (
- (A.TypeName sa) +> A.rewrap ta,
- (B.TypeName (sb,typb), [isb])
- ))
- else fail
-
- | _, (B.TypeOfExpr e, ii) -> fail
- | _, (B.TypeOfType e, ii) -> fail
-
- | _, (B.ParenType e, ii) -> fail (* todo ?*)
- | A.EnumName(en,namea), (B.EnumName nameb, ii) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
- tokenf en ib1 >>= (fun en ib1 ->
- return (
- (A.EnumName (en, namea)) +> A.rewrap ta,
- (B.EnumName nameb, [ib1;ib2])
- )))
-
- | _, (B.Enum _, _) -> fail (* todo cocci ?*)
-
- | _,
- ((B.TypeName (_, _) | B.StructUnionName (_, _) | B.EnumName _ |
- B.StructUnion (_, _, _) |
- B.FunctionType _ | B.Array (_, _) | B.Pointer _ |
- B.BaseType _),
- _)
- -> fail
-
-
-(* todo: iso on sign, if not mentioned then free. tochange?
- * but that require to know if signed int because explicit
- * signed int, or because implicit signed int.
- *)
-
-and sign signa signb =
- match signa, signb with
- | None, None -> return (None, [])
- | Some signa, Some (signb, ib) ->
- if equal_sign (term signa) signb
- then tokenf signa ib >>= (fun signa ib ->
- return (Some signa, [ib])
- )
- else fail
- | _, _ -> fail
-
-
-and minusize_list iixs =
- iixs +> List.fold_left (fun acc ii ->
- acc >>= (fun xs ys ->
- tokenf minusizer ii >>= (fun minus ii ->
- return (minus::xs, ii::ys)
- ))) (return ([],[]))
- >>= (fun _xsminys ys ->
- return ((), List.rev ys)
- )
-
-and storage_optional_allminus allminus stoa (stob, iistob) =
- (* "iso-by-absence" for storage, and return type. *)
- X.optional_storage_flag (fun optional_storage ->
- match stoa, stob with
- | None, (stobis, inline) ->
- let do_minus () =
- if allminus
- then
- minusize_list iistob >>= (fun () iistob ->
- return (None, (stob, iistob))
- )
- else return (None, (stob, iistob))
- in
-
- (match optional_storage, stobis with
- | false, B.NoSto -> do_minus ()
- | false, _ -> fail
- | true, B.NoSto -> do_minus ()
- | true, _ ->
- if !Flag.show_misc
- then pr2_once "USING optional_storage builtin isomorphism";
- do_minus()
- )
-
- | Some x, ((stobis, inline)) ->
- if equal_storage (term x) stobis
- then
- match iistob with
- | [i1] ->
- tokenf x i1 >>= (fun x i1 ->
- return (Some x, ((stobis, inline), [i1]))
- )
- (* or if have inline ? have to do a split_storage_inline a la
- * split_signb_baseb_ii *)
- | _ -> raise Impossible
- else fail
- )
-
-
-
-
-
-and fullType_optional_allminus allminus tya retb =
- match tya with
- | None ->
- if allminus
- then
- X.distrf_type minusizer retb >>= (fun _x retb ->
- return (None, retb)
- )
-
- else return (None, retb)
- | Some tya ->
- fullType tya retb >>= (fun tya retb ->
- return (Some tya, retb)
- )
-
-
-
-(*---------------------------------------------------------------------------*)
-
-and compatible_base_type a signa b =
- let ok = return ((),()) in
-
- match a, b with
- | Type_cocci.VoidType, B.Void ->
- assert (signa = None);
- ok
- | Type_cocci.CharType, B.IntType B.CChar when signa = None ->
- ok
- | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb
- | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
- compatible_sign signa signb
- | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
- compatible_sign signa signb
- | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
- compatible_sign signa signb
- | _, B.IntType (B.Si (signb, B.CLongLong)) ->
- pr2_once "no longlong in cocci";
- fail
- | Type_cocci.FloatType, B.FloatType B.CFloat ->
- assert (signa = None);
- ok
- | Type_cocci.DoubleType, B.FloatType B.CDouble ->
- assert (signa = None);
- ok
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
- | Type_cocci.BoolType, _ -> failwith "no booltype in C"
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-and compatible_base_type_meta a signa qua b ii local =
- match a, b with
- | Type_cocci.MetaType(ida,keep,inherited),
- B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb >>= fun _ _ ->
- let newb = ((qua, (B.BaseType (B.IntType B.CChar),ii)),local) in
- compatible_type a newb
- | Type_cocci.MetaType(ida,keep,inherited), B.IntType (B.Si (signb, ty)) ->
- compatible_sign signa signb >>= fun _ _ ->
- let newb =
- ((qua, (B.BaseType (B.IntType (B.Si (B.Signed, ty))),ii)),local) in
- compatible_type a newb
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
-
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
-
-
-and compatible_type a (b,local) =
- let ok = return ((),()) in
-
- let rec loop = function
- | Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
- compatible_base_type a None b
-
- | Type_cocci.SignedT (signa,None), (qua, (B.BaseType b,ii)) ->
- compatible_base_type Type_cocci.IntType (Some signa) b
-
- | Type_cocci.SignedT (signa,Some ty), (qua, (B.BaseType b,ii)) ->
- (match ty with
- Type_cocci.BaseType ty ->
- compatible_base_type ty (Some signa) b
- | Type_cocci.MetaType(ida,keep,inherited) ->
- compatible_base_type_meta ty (Some signa) qua b ii local
- | _ -> failwith "not possible")
-
- | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
- loop (a,b)
- | Type_cocci.FunctionPointer a, _ ->
- failwith
- "TODO: function pointer type doesn't store enough information to determine compatability"
- | Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
- (* no size info for cocci *)
- loop (a,b)
- | Type_cocci.StructUnionName (sua, _, sa),
- (qub, (B.StructUnionName (sub, sb),ii)) ->
- if equal_structUnion_type_cocci sua sub && sa = sb
- then ok
- else fail
- | Type_cocci.EnumName (_, sa),
- (qub, (B.EnumName (sb),ii)) ->
- if sa = sb
- then ok
- else fail
- | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
- if sa = sb
- then ok
- else fail
-
- | Type_cocci.ConstVol (qua, a), (qub, b) ->
- if (fst qub).B.const && (fst qub).B.volatile
- then
- begin
- pr2_once ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
- fail
- end
- else
- if
- (match qua with
- | Type_cocci.Const -> (fst qub).B.const
- | Type_cocci.Volatile -> (fst qub).B.volatile
- )
- then loop (a,(Ast_c.nQ, b))
- else fail
-
- | Type_cocci.MetaType (ida,keep,inherited), typb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (A.make_mcode ida, B.MetaTypeVal typb, max_min)
- (fun () -> ok
- )
-
- (* subtil: must be after the MetaType case *)
- | a, (qub, (B.TypeName (sb,Some b), ii)) ->
- (* kind of typedef iso *)
- loop (a,b)
-
-
-
-
-
- (* for metavariables of type expression *^* *)
- | Type_cocci.Unknown , _ -> ok
-
- | (_,
- (_,
- ((
- B.TypeOfType _|B.TypeOfExpr _|B.ParenType _|
- B.EnumName _|B.StructUnion (_, _, _)|B.Enum (_, _)
- ),
- _))) -> fail
-
- | (_,
- (_,
- ((
- B.StructUnionName (_, _)|
- B.FunctionType _|
- B.Array (_, _)|B.Pointer _|B.TypeName _|
- B.BaseType _
- ),
- _))) -> fail
-
-
- in
- loop (a,b)
-
-and compatible_sign signa signb =
- let ok = return ((),()) in
- match signa, signb with
- | None, B.Signed
- | Some Type_cocci.Signed, B.Signed
- | Some Type_cocci.Unsigned, B.UnSigned
- -> ok
- | _ -> fail
-
-
-and equal_structUnion_type_cocci a b =
- match a, b with
- | Type_cocci.Struct, B.Struct -> true
- | Type_cocci.Union, B.Union -> true
- | _, (B.Struct | B.Union) -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-and inc_file (a, before_after) (b, h_rel_pos) =
-
- let rec aux_inc (ass, bss) passed =
- match ass, bss with
- | [], [] -> true
- | [A.IncDots], _ ->
- let passed = List.rev passed in
-
- (match before_after, !h_rel_pos with
- | IncludeNothing, _ -> true
- | IncludeMcodeBefore, Some x ->
- List.mem passed (x.Ast_c.first_of)
-
- | IncludeMcodeAfter, Some x ->
- List.mem passed (x.Ast_c.last_of)
-
- (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
- | _, None -> false
- )
-
- | (A.IncPath x)::xs, y::ys -> x = y && aux_inc (xs, ys) (x::passed)
- | _ -> failwith "IncDots not in last place or other pb"
-
- in
-
- match a, b with
- | A.Local ass, B.Local bss ->
- aux_inc (ass, bss) []
- | A.NonLocal ass, B.NonLocal bss ->
- aux_inc (ass, bss) []
- | _ -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-
-and (define_params: sequence ->
- (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- define_paramsbis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-(* todo? facto code with argument and parameters ? *)
-and define_paramsbis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.DPdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_define_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- define_paramsbis eas endxs >>= (fun eas endxs ->
- return (
- (A.DPdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.DPComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DPComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.DPComma ia1, ebs ->
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else
- (define_paramsbis eas ebs) (* try optional comma trick *)
-
- | (A.OptDParam _ | A.UniqueDParam _), _ ->
- failwith "handling Opt/Unique for define parameters"
-
- | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
- | A.DParam ida, (Left (idb, ii))::ebs ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DParam ida)+> A.rewrap ea :: eas,
- (Left (idb, [ib1]))::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-(*****************************************************************************)
-(* Entry points *)
-(*****************************************************************************)
-
-(* no global solution for positions here, because for a statement metavariable
-we want a MetaStmtVal, and for the others, it's not clear what we want *)
-
-let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
- fun re node ->
- let rewrap x =
- x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
- in
- X.all_bound (A.get_inherited re) >&&>
-
- rewrap (
- match A.unwrap re, F.unwrap node with
-
- (* note: the order of the clauses is important. *)
-
- | _, F.Enter | _, F.Exit | _, F.ErrorExit -> fail2()
-
- (* the metaRuleElem contains just '-' information. We dont need to add
- * stuff in the environment. If we need stuff in environment, because
- * there is a + S somewhere, then this will be done via MetaStmt, not
- * via MetaRuleElem.
- * Can match TrueNode/FalseNode/... so must be placed before those cases.
- *)
-
- | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
- let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
- (match unwrap_node with
- | F.CaseNode _
- | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
- | F.InLoopNode ->
- if X.mode = PatternMode
- then return default
- else
- if mcode_contain_plus (mcodekind mcode)
- then failwith "try add stuff on fake node"
- (* minusize or contextize a fake node is ok *)
- else return default
-
- | F.EndStatement None ->
- if X.mode = PatternMode then return default
- else
- (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
- if mcode_contain_plus (mcodekind mcode)
- then
- let fake_info = Ast_c.fakeInfo() in
- distrf distrf_node (mcodekind mcode)
- (F.EndStatement (Some fake_info))
- else return unwrap_node
- *)
- raise Todo
-
- | F.EndStatement (Some i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.MetaRuleElem (mcode,keep, inherited),
- F.EndStatement (Some i1)
- ))
-
- | F.FunHeader _ ->
- if X.mode = PatternMode then return default
- else failwith "a MetaRuleElem can't transform a headfunc"
- | _n ->
- if X.mode = PatternMode then return default
- else
- X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
- return (
- A.MetaRuleElem(mcode,keep, inherited),
- F.unwrap node
- ))
- )
-
-
- (* rene cant have found that a state containing a fake/exit/... should be
- * transformed
- * TODO: and F.Fake ?
- *)
- | _, F.EndStatement _ | _, F.CaseNode _
- | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
- | _, F.InLoopNode
- -> fail2()
-
- (* really ? diff between pattern.ml and transformation.ml *)
- | _, F.Fake -> fail2()
-
-
- (* cas general: a Meta can match everything. It matches only
- * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
- * So can't have been called in transform.
- *)
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
-
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
- (* todo: should not happen in transform mode *)
-
- (match Control_flow_c.extract_fullstatement node with
- | Some stb ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_stmt stb) in
- X.envf keep inherited (ida, Ast_c.MetaStmtVal stb, max_min)
- (fun () ->
- (* no need tag ida, we can't be called in transform-mode *)
- return (
- A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
- unwrap_node
- )
- )
- | None -> fail
- )
-
- (* not me?: *)
- | A.MetaStmtList _, _ ->
- failwith "not handling MetaStmtList"
-
- | A.TopExp ea, F.DefineExpr eb ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.TopExp ea,
- F.DefineExpr eb
- ))
-
- | A.TopExp ea, F.DefineType eb ->
- (match A.unwrap ea with
- A.TypeExp(ft) ->
- fullType ft eb >>= (fun ft eb ->
- return (
- A.TopExp (A.rewrap ea (A.TypeExp(ft))),
- F.DefineType eb
- ))
- | _ -> fail)
-
-
-
- (* It is important to put this case before the one that fails because
- * of the lack of the counter part of a C construct in SmPL (for instance
- * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
- * yet certain constructs, those constructs may contain expression
- * that we still want and can transform.
- *)
-
- | A.Exp exp, nodeb ->
-
- (* kind of iso, initialisation vs affectation *)
- let node =
- match A.unwrap exp, nodeb with
- | A.Assignment (ea, op, eb, true), F.Decl decl ->
- initialisation_to_affectation decl +> F.rewrap node
- | _ -> node
- in
-
-
- (* Now keep fullstatement inside the control flow node,
- * so that can then get in a MetaStmtVar the fullstatement to later
- * pp back when the S is in a +. But that means that
- * Exp will match an Ifnode even if there is no such exp
- * inside the condition of the Ifnode (because the exp may
- * be deeper, in the then branch). So have to not visit
- * all inside a node anymore.
- *
- * update: j'ai choisi d'accrocher au noeud du CFG Ã la
- * fois le fullstatement et le partialstatement et appeler le
- * visiteur que sur le partialstatement.
- *)
- let expfn =
- match Ast_cocci.get_pos re with
- | None -> expression
- | Some pos ->
- (fun ea eb ->
- let (max,min) =
- Lib_parsing_c.max_min_by_pos (Lib_parsing_c.ii_of_expr eb) in
- let keep = Type_cocci.Unitary in
- let inherited = false in
- let max_min _ = failwith "no pos" in
- X.envf keep inherited (pos, B.MetaPosVal (min,max), max_min)
- (fun () ->
- expression ea eb
- )
- )
- in
- X.cocciExp expfn exp node >>= (fun exp node ->
- return (
- A.Exp exp,
- F.unwrap node
- )
- )
-
- | A.Ty ty, nodeb ->
- X.cocciTy fullType ty node >>= (fun ty node ->
- return (
- A.Ty ty,
- F.unwrap node
- )
- )
-
- | A.TopInit init, nodeb ->
- X.cocciInit initialiser init node >>= (fun init node ->
- return (
- A.TopInit init,
- F.unwrap node
- )
- )
-
-
- | A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
- F.FunHeader ({B.f_name = idb;
- f_type = (retb, (paramsb, (isvaargs, iidotsb)));
- f_storage = stob;
- f_attr = attrs;
- f_body = body;
- f_old_c_style = oldstyle;
- }, ii) ->
- assert (null body);
-
- if oldstyle <> None
- then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
-
-
- (* fninfoa records the order in which the SP specified the various
- information, but this isn't taken into account in the matching.
- Could this be a problem for transformation? *)
- let stoa =
- match
- List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
- with [A.FStorage(s)] -> Some s | _ -> None in
- let tya =
- match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
- with [A.FType(t)] -> Some t | _ -> None in
-
- (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
- with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
-
- (match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
- with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
-
- (match ii with
- | iidb::ioparenb::icparenb::iifakestart::iistob ->
-
- (* maybe important to put ident as the first tokens to transform.
- * It's related to transform_proto. So don't change order
- * between the >>=.
- *)
- ident LocalFunction ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- tokenf oparen ioparenb >>= (fun oparen ioparenb ->
- tokenf cparen icparenb >>= (fun cparen icparenb ->
- parameters (seqstyle paramsa)
- (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- storage_optional_allminus allminus
- stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
- (
- if isvaargs
- then
- pr2_once
- ("Not handling well variable length arguments func. "^
- "You have been warned");
- if allminus
- then minusize_list iidotsb
- else return ((),iidotsb)
- ) >>= (fun () iidotsb ->
-
- fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
-
- let fninfoa =
- (match stoa with Some st -> [A.FStorage st] | None -> []) ++
- (match tya with Some t -> [A.FType t] | None -> [])
-
- in
-
- return (
- A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
- paramsa,cparen),
- F.FunHeader ({B.f_name = idb;
- f_type = (retb, (paramsb, (isvaargs, iidotsb)));
- f_storage = stob;
- f_attr = attrs;
- f_body = body;
- f_old_c_style = oldstyle; (* TODO *)
- },
- iidb::ioparenb::icparenb::iifakestart::iistob)
- )
- ))))))))
- | _ -> raise Impossible
- )
-
-
-
-
-
-
- | A.Decl (mckstart,allminus,decla), F.Decl declb ->
- declaration (mckstart,allminus,decla) declb >>=
- (fun (mckstart,allminus,decla) declb ->
- return (
- A.Decl (mckstart,allminus,decla),
- F.Decl declb
- ))
-
-
- | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.SeqStart mcode,
- F.SeqStart (st, level, i1)
- ))
-
- | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.SeqEnd mcode,
- F.SeqEnd (level, i1)
- ))
-
- | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- A.ExprStatement (ea, ia1),
- F.ExprStatement (st, (Some eb, [ib1]))
- )
- ))
-
-
- | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- A.IfHeader (ia1, ia2, ea, ia3),
- F.IfHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | A.Else ia, F.Else ib ->
- tokenf ia ib >>= (fun ia ib ->
- return (A.Else ia, F.Else ib)
- )
-
- | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- return (
- A.WhileHeader (ia1, ia2, ea, ia3),
- F.WhileHeader (st, (eb, [ib1;ib2;ib3]))
- )))))
-
- | A.DoHeader ia, F.DoHeader (st, ib) ->
- tokenf ia ib >>= (fun ia ib ->
- return (
- A.DoHeader ia,
- F.DoHeader (st, ib)
- ))
- | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
- let (ib1, ib2, ib3, ib4) = tuple_of_list4 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- return (
- A.WhileTail (ia1,ia2,ea,ia3,ia4),
- F.DoWhileTail (eb, [ib1;ib2;ib3;ib4])
- ))))))
- | A.IteratorHeader (ia1, ia2, eas, ia3), F.MacroIterHeader (st, ((s,ebs),ii))
- ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
-
- ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- A.IteratorHeader (ia1, ia2, eas, ia3),
- F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
- )))))
-
-
-
- | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,ib3s), (eb2opt,ib4s), (eb3opt,ib4vide)), ii))
- ->
- assert (null ib4vide);
- let (ib1, ib2, ib5) = tuple_of_list3 ii in
- let ib3 = tuple_of_list1 ib3s in
- let ib4 = tuple_of_list1 ib4s in
-
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- tokenf ia5 ib5 >>= (fun ia5 ib5 ->
- option expression ea1opt eb1opt >>= (fun ea1opt eb1opt ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- option expression ea3opt eb3opt >>= (fun ea3opt eb3opt ->
- return (
- A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,[ib3]), (eb2opt,[ib4]), (eb3opt,[])),
- [ib1;ib2;ib5]))
-
- )))))))))
-
-
- | A.SwitchHeader(ia1,ia2,ea,ia3), F.SwitchHeader (st, (eb,ii)) ->
- let (ib1, ib2, ib3) = tuple_of_list3 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.SwitchHeader(ia1,ia2,ea,ia3),
- F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Break (ia1, ia2),
- F.Break (st, ((),[ib1;ib2]))
- )))
-
- | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Continue (ia1, ia2),
- F.Continue (st, ((),[ib1;ib2]))
- )))
-
- | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- return (
- A.Return (ia1, ia2),
- F.Return (st, ((),[ib1;ib2]))
- )))
-
- | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
- return (
- A.ReturnExpr (ia1, ea, ia2),
- F.ReturnExpr (st, (eb, [ib1;ib2]))
- ))))
-
-
-
- | A.Include(incla,filea),
- F.Include {B.i_include = (fileb, ii);
- B.i_rel_pos = h_rel_pos;
- B.i_is_in_ifdef = inifdef;
- B.i_content = copt;
- } ->
- assert (copt = None);
-
- let include_requirment =
- match mcodekind incla, mcodekind filea with
- | A.CONTEXT (_, A.BEFORE _), _ ->
- IncludeMcodeBefore
- | _, A.CONTEXT (_, A.AFTER _) ->
- IncludeMcodeAfter
- | _ ->
- IncludeNothing
- in
-
- let (inclb, iifileb) = tuple_of_list2 ii in
- if inc_file (term filea, include_requirment) (fileb, h_rel_pos)
- then
- tokenf incla inclb >>= (fun incla inclb ->
- tokenf filea iifileb >>= (fun filea iifileb ->
- return (
- A.Include(incla, filea),
- F.Include {B.i_include = (fileb, [inclb;iifileb]);
- B.i_rel_pos = h_rel_pos;
- B.i_is_in_ifdef = inifdef;
- B.i_content = copt;
- }
- )))
- else fail
-
-
-
- | A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
- let (defineb, iidb, ieol) = tuple_of_list3 ii in
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- tokenf definea defineb >>= (fun definea defineb ->
- (match A.unwrap params, defkind with
- | A.NoParams, B.DefineVar ->
- return (
- A.NoParams +> A.rewrap params,
- B.DefineVar
- )
- | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
- let (lpb, rpb) = tuple_of_list2 ii in
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
-
- define_params (seqstyle eas) (A.undots eas) ebs >>=
- (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- A.DParams (lpa,eas,rpa) +> A.rewrap params,
- B.DefineFunc (ebs,[lpb;rpb])
- )
- )))
- | _ -> fail
- ) >>= (fun params defkind ->
- return (
- A.DefineHeader (definea, ida, params),
- F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
- ))
- ))
-
-
- | A.Default(def,colon), F.Default (st, ((),ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf def ib1 >>= (fun def ib1 ->
- tokenf colon ib2 >>= (fun colon ib2 ->
- return (
- A.Default(def,colon),
- F.Default (st, ((),[ib1;ib2]))
- )))
-
-
-
- | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- tokenf case ib1 >>= (fun case ib1 ->
- expression ea eb >>= (fun ea eb ->
- tokenf colon ib2 >>= (fun colon ib2 ->
- return (
- A.Case(case,ea,colon),
- F.Case (st, (eb,[ib1;ib2]))
- ))))
-
- (* only occurs in the predicates generated by asttomember *)
- | A.DisjRuleElem eas, _ ->
- (eas +>
- List.fold_left (fun acc ea -> acc >|+|> (rule_elem_node ea node)) fail)
- >>= (fun ea eb -> return (A.unwrap ea,F.unwrap eb))
-
- | _, F.ExprStatement (_, (None, ii)) -> fail (* happen ? *)
-
- | A.Label(id,dd), F.Label (st,(s,ii)) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- let (string_of_id,rebuild) =
- match A.unwrap id with
- A.Id(s) -> (s,function s -> A.rewrap id (A.Id(s)))
- | _ -> failwith "labels with metavariables not supported" in
- if (term string_of_id) =$= s
- then
- tokenf string_of_id ib1 >>= (fun string_of_id ib1 ->
- tokenf dd ib2 >>= (fun dd ib2 ->
- return (
- A.Label(rebuild string_of_id,dd),
- F.Label (st,(s,[ib1;ib2]))
- )))
- else fail
-
- | A.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- tokenf goto ib1 >>= (fun goto ib1 ->
- ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
- tokenf sem ib3 >>= (fun sem ib3 ->
- return(
- A.Goto(goto,id,sem),
- F.Goto (st,(s,[ib1;ib2;ib3]))
- ))))
-
- (* have not a counter part in coccinelle, for the moment *)
- (* todo?: print a warning at least ? *)
- | _, F.CaseRange _
- | _, F.Asm _
- | _, F.MacroTop _
- -> fail2()
-
- | _, (F.IfdefEndif _|F.IfdefElse _|F.IfdefHeader _)
- -> fail2 ()
-
- | _,
- (F.MacroStmt (_, _)| F.DefineDoWhileZeroHeader _| F.EndNode|F.TopNode)
- -> fail
- | _,
- (F.Label (_, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
- F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
- F.DefineType _|F.DefineExpr _|F.DefineTodo|
- F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|F.MacroIterHeader (_, _)|
- F.SwitchHeader (_, _)|F.ForHeader (_, _)|F.DoWhileTail _|F.DoHeader (_, _)|
- F.WhileHeader (_, _)|F.Else _|F.IfHeader (_, _)|
- F.SeqEnd (_, _)|F.SeqStart (_, _, _)|
- F.Decl _|F.FunHeader _)
- -> fail
-
-
- )
-end
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-(*****************************************************************************)
-(* Types *)
-(*****************************************************************************)
-
-type protocol_match =
- | MatchPos of Ograph_extended.nodei
- | MatchNeg of Ograph_extended.nodei
- | NoMatch
- (* could generate exn instead, but in many cases as for my acomment gui
- * I still want to print the match for the other elements, so one failure
- * should not stop everything
- *)
- | MatchProblem of string
-
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-(*****************************************************************************)
-(* Specific finder wrappers *)
-(*****************************************************************************)
-let (find_nodes_satisfying_pattern:
- Control_flow_c.cflow -> Ast_cocci.rule_elem -> Ograph_extended.nodei list)=
- fun flow pattern ->
-
- let nodes = flow#nodes in
- let nodes = nodes#tolist in
- nodes +> Common.map_filter (fun (nodei, node) ->
- let res =
- Pattern_c.match_re_node [] (* dropped isos *)
- pattern node
- []
- in
- if List.length res > 0
- then Some nodei
- else None
- )
-
-
-let (find_nodes_containing_expr:
- Control_flow_c.cflow -> Ast_c.expression -> Ograph_extended.nodei list)=
- fun flow expr ->
-
- let expr = Lib_parsing_c.real_al_expr expr in
-
- let nodes = flow#nodes in
- let nodes = nodes#tolist in
- nodes +> Common.map_filter (fun (nodei, node) ->
- let node = Lib_parsing_c.real_al_node node in
-
- let found = ref false in
-
- Visitor_c.vk_node { Visitor_c.default_visitor_c with
- Visitor_c.kexpr = (fun (k, bigf) e2 ->
- if e2 =*= expr
- then found := true
- else k e2
- );
- } node;
-
- if !found
- then Some nodei
- else None
- )
-
-
-
-(*****************************************************************************)
-(* Main entries *)
-(*****************************************************************************)
-
-(*
- *
- * todo: Check for all path upwards ?
- *)
-
-let (find_nodes_upward_satisfying_protocol:
- Ograph_extended.nodei -> Control_flow_c.cflow ->
- Ast_cocci.rule_elem * Ast_cocci.rule_elem ->
- protocol_match
- ) =
- fun nodei flow (pattern1, pattern2) ->
-
- let already_done = ref [nodei] in
- let found = ref [] in
-
- let rec aux nodei =
- let pred =
- List.map fst ((flow#predecessors nodei)#tolist)
- in
- pred +> List.iter (fun nodei2 ->
- if List.mem nodei2 !already_done
- then ()
- else begin
- Common.push2 nodei2 already_done;
-
- let node2 = flow#nodes#assoc nodei2 in
-
- let res1 =
- Pattern_c.match_re_node []
- pattern1 node2
- []
- in
- let res2 =
- Pattern_c.match_re_node []
- pattern2 node2
- []
- in
- match List.length res1 > 0, List.length res2 > 0 with
- | true, false ->
- Common.push2 (MatchPos nodei2) found
- | false, true ->
- Common.push2 (MatchNeg nodei2) found
- | true, true ->
- failwith "wierd, node match both rule_elem"
- | false, false ->
- aux nodei2
- end
- );
- in
- aux nodei;
- (match !found with
- | [] -> NoMatch
- | [x] -> x
- | x::y::ys ->
- failwith "multiple found";
- )
-
-
-
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-module Flag_engine = Flag_matcher
-(*****************************************************************************)
-(* The functor argument *)
-(*****************************************************************************)
-
-(* info passed recursively in monad in addition to binding *)
-type xinfo = {
- optional_storage_iso : bool;
- optional_qualifier_iso : bool;
- value_format_iso : bool;
-}
-
-module XMATCH = struct
-
- (* ------------------------------------------------------------------------*)
- (* Combinators history *)
- (* ------------------------------------------------------------------------*)
- (*
- * version0:
- * type ('a, 'b) matcher = 'a -> 'b -> bool
- *
- * version1: same but with a global variable holding the current binding
- * BUT bug
- * - can have multiple possibilities
- * - globals sux
- * - sometimes have to undo, cos if start match, then it binds,
- * and if later it does not match, then must undo the first binds.
- * ex: when match parameters, can try to match, but then we found far
- * later that the last argument of a function does not match
- * => have to uando the binding !!!
- * (can handle that too with a global, by saving the
- * global, ... but sux)
- * => better not use global
- *
- * version2:
- * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
- *
- * Empty list mean failure (let matchfailure = []).
- * To be able to have pretty code, have to use partial application
- * powa, and so the type is in fact
- *
- * version3:
- * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
- *
- * Then by defining the correct combinators, can have quite pretty code (that
- * looks like the clean code of version0).
- *
- * opti: return a lazy list of possible matchs ?
- *
- * version4: type tin = Lib_engine.metavars_binding
- *)
-
- (* ------------------------------------------------------------------------*)
- (* Standard type and operators *)
- (* ------------------------------------------------------------------------*)
-
- type tin = {
- extra: xinfo;
- binding: Lib_engine.metavars_binding;
- binding0: Lib_engine.metavars_binding; (* inherited bindings *)
- }
- (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
- (* opti? use set instead of list *)
- type 'x tout = ('x * Lib_engine.metavars_binding) list
-
- type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
-
- (* was >&&> *)
- let (>>=) m1 m2 = fun tin ->
- let xs = m1 tin in
- let xxs = xs +> List.map (fun ((a,b), binding) ->
- m2 a b {tin with binding = binding}
- ) in
- List.flatten xxs
-
- (* Je compare les bindings retournés par les differentes branches.
- * Si la deuxieme branche amene a des bindings qui sont deja presents
- * dans la premiere branche, alors je ne les accepte pas.
- *
- * update: still useful now that julia better handle Exp directly via
- * ctl tricks using positions ?
- *)
- let (>|+|>) m1 m2 = fun tin ->
-(* CHOICE
- let xs = m1 tin in
- if null xs
- then m2 tin
- else xs
-*)
- let res1 = m1 tin in
- let res2 = m2 tin in
- let list_bindings_already = List.map snd res1 in
- res1 ++
- (res2 +> List.filter (fun (x, binding) ->
- not
- (list_bindings_already +> List.exists (fun already ->
- Lib_engine.equal_binding binding already))
- ))
-
-
-
-
- let (>||>) m1 m2 = fun tin ->
-(* CHOICE
- let xs = m1 tin in
- if null xs
- then m2 tin
- else xs
-*)
- (* opti? use set instead of list *)
- m1 tin ++ m2 tin
-
-
- let return res = fun tin ->
- [res, tin.binding]
-
- let fail = fun tin ->
- []
-
- let (>&&>) f m = fun tin ->
- if f tin
- then m tin
- else fail tin
-
-
- let mode = Cocci_vs_c.PatternMode
-
- (* ------------------------------------------------------------------------*)
- (* Exp *)
- (* ------------------------------------------------------------------------*)
- let cocciExp = fun expf expa node -> fun tin ->
-
- let globals = ref [] in
- let bigf = {
- (* julia's style *)
- Visitor_c.default_visitor_c with
- Visitor_c.kexpr = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | [] -> (* failed *) k expb
- | xs ->
- globals := xs @ !globals;
- if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
- );
- (* pad's style.
- * push2 expr globals; k expr
- * ...
- * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
- * (return false)
- *
- *)
- }
- in
- Visitor_c.vk_node bigf node;
- !globals +> List.map (fun ((a, _exp), binding) ->
- (a, node), binding
- )
-
- (* same as cocciExp, but for expressions in an expression, not expressions
- in a node *)
- let cocciExpExp = fun expf expa expb -> fun tin ->
-
- let globals = ref [] in
- let bigf = {
- (* julia's style *)
- Visitor_c.default_visitor_c with
- Visitor_c.kexpr = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | [] -> (* failed *) k expb
- | xs ->
- globals := xs @ !globals;
- if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
- );
- (* pad's style.
- * push2 expr globals; k expr
- * ...
- * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
- * (return false)
- *
- *)
- }
- in
- Visitor_c.vk_expr bigf expb;
- !globals +> List.map (fun ((a, _exp), binding) ->
- (a, expb), binding
- )
-
- let cocciTy = fun expf expa node -> fun tin ->
-
- let globals = ref [] in
- let bigf = {
- Visitor_c.default_visitor_c with
- Visitor_c.ktype = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | [] -> (* failed *) k expb
- | xs -> globals := xs @ !globals);
-
- }
- in
- Visitor_c.vk_node bigf node;
- !globals +> List.map (fun ((a, _exp), binding) ->
- (a, node), binding
- )
-
- let cocciInit = fun expf expa node -> fun tin ->
-
- let globals = ref [] in
- let bigf = {
- Visitor_c.default_visitor_c with
- Visitor_c.kini = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | [] -> (* failed *) k expb
- | xs -> globals := xs @ !globals);
-
- }
- in
- Visitor_c.vk_node bigf node;
- !globals +> List.map (fun ((a, _exp), binding) ->
- (a, node), binding
- )
-
-
- (* ------------------------------------------------------------------------*)
- (* Distribute mcode *)
- (* ------------------------------------------------------------------------*)
- let tag_mck_pos mck posmck =
- match mck with
- | Ast_cocci.PLUS -> Ast_cocci.PLUS
- | Ast_cocci.CONTEXT (pos, xs) ->
- assert (pos = Ast_cocci.NoPos || pos = Ast_cocci.DontCarePos);
- Ast_cocci.CONTEXT (posmck, xs)
- | Ast_cocci.MINUS (pos, xs) ->
- assert (pos = Ast_cocci.NoPos || pos = Ast_cocci.DontCarePos);
- Ast_cocci.MINUS (posmck, xs)
-
-
- let tag_mck_pos_mcode (x,info,mck,pos) posmck stuff = fun tin ->
- [((x, info, tag_mck_pos mck posmck, pos),stuff), tin.binding]
-
-
- let distrf (ii_of_x_f) =
- fun mcode x -> fun tin ->
- let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
- in
- let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*)
- in
- tag_mck_pos_mcode mcode posmck x tin
-
- let distrf_e = distrf (Lib_parsing_c.ii_of_expr)
- let distrf_args = distrf (Lib_parsing_c.ii_of_args)
- let distrf_type = distrf (Lib_parsing_c.ii_of_type)
- let distrf_param = distrf (Lib_parsing_c.ii_of_param)
- let distrf_params = distrf (Lib_parsing_c.ii_of_params)
- let distrf_ini = distrf (Lib_parsing_c.ii_of_ini)
- let distrf_node = distrf (Lib_parsing_c.ii_of_node)
- let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields)
- let distrf_cst = distrf (Lib_parsing_c.ii_of_cst)
- let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params)
-
-
- (* ------------------------------------------------------------------------*)
- (* Constraints on metavariable values *)
- (* ------------------------------------------------------------------------*)
- let check_constraints matcher constraints exp = fun f tin ->
- let rec loop = function
- [] -> f () tin (* success *)
- | c::cs ->
- match matcher c exp tin with
- [] (* failure *) -> loop cs
- | _ (* success *) -> fail tin in
- loop constraints
-
- let check_pos_constraints constraints pvalu f tin =
- check_constraints
- (fun c exp tin ->
- let success = [[]] in
- let failure = [] in
- (* relies on the fact that constraints on pos variables must refer to
- inherited variables *)
- (match Common.optionise (fun () -> tin.binding0 +> List.assoc c) with
- Some valu' ->
- if Cocci_vs_c.equal_metavarval exp valu'
- then success else failure
- | None ->
- (* if the variable is not there, it puts no constraints *)
- (* not sure this is still useful *)
- failure))
- constraints pvalu f tin
-
- (* ------------------------------------------------------------------------*)
- (* Environment *)
- (* ------------------------------------------------------------------------*)
- (* pre: if have declared a new metavar that hide another one, then
- * must be passed with a binding that deleted this metavar
- *
- * Here we dont use the keep argument of julia. cf f(X,X), J'ai
- * besoin de garder le X en interne, meme si julia s'en fout elle du
- * X et qu'elle a mis X a DontSaved.
- *)
- let check_add_metavars_binding strip _keep inherited = fun (k, valu) tin ->
- if inherited
- then
- match Common.optionise (fun () -> tin.binding0 +> List.assoc k) with
- | Some (valu') ->
- if Cocci_vs_c.equal_metavarval valu valu'
- then Some tin.binding
- else None
- | None -> None
- else
- match Common.optionise (fun () -> tin.binding +> List.assoc k) with
- | Some (valu') ->
- if Cocci_vs_c.equal_metavarval valu valu'
- then Some tin.binding
- else None
-
- | None ->
- let valu' =
- match valu with
- Ast_c.MetaIdVal a -> Ast_c.MetaIdVal a
- | Ast_c.MetaFuncVal a -> Ast_c.MetaFuncVal a
- | Ast_c.MetaLocalFuncVal a -> Ast_c.MetaLocalFuncVal a (*more?*)
- | Ast_c.MetaExprVal a ->
- Ast_c.MetaExprVal
- (if strip
- then Lib_parsing_c.al_expr a
- else Lib_parsing_c.semi_al_expr a)
- | Ast_c.MetaExprListVal a ->
- Ast_c.MetaExprListVal
- (if strip
- then Lib_parsing_c.al_arguments a
- else Lib_parsing_c.semi_al_arguments a)
-
- | Ast_c.MetaStmtVal a ->
- Ast_c.MetaStmtVal
- (if strip
- then Lib_parsing_c.al_statement a
- else Lib_parsing_c.semi_al_statement a)
- | Ast_c.MetaTypeVal a ->
- Ast_c.MetaTypeVal
- (if strip
- then Lib_parsing_c.al_type a
- else Lib_parsing_c.semi_al_type a)
-
- | Ast_c.MetaListlenVal a -> Ast_c.MetaListlenVal a
-
- | Ast_c.MetaParamVal a -> failwith "not handling MetaParamVal"
- | Ast_c.MetaParamListVal a ->
- Ast_c.MetaParamListVal
- (if strip
- then Lib_parsing_c.al_params a
- else Lib_parsing_c.semi_al_params a)
-
- | Ast_c.MetaPosVal (pos1,pos2) -> Ast_c.MetaPosVal (pos1,pos2)
- | Ast_c.MetaPosValList l -> Ast_c.MetaPosValList l
- in Some (tin.binding +> Common.insert_assoc (k, valu'))
-
- let envf keep inherited = fun (k, valu, get_max_min) f tin ->
- let x = Ast_cocci.unwrap_mcode k in
- match check_add_metavars_binding true keep inherited (x, valu) tin with
- | Some binding ->
- let new_tin = {tin with binding = binding} in
- (match Ast_cocci.get_pos_var k with
- Ast_cocci.MetaPos(name,constraints,per,keep,inherited) ->
- let pvalu =
- let (file,current_element,min,max) = get_max_min() in
- Ast_c.MetaPosValList[(file,current_element,min,max)] in
- (* check constraints. success means that there is a match with
- one of the constraints, which will ultimately result in
- failure. *)
- check_pos_constraints constraints pvalu
- (function () ->
- (* constraints are satisfied, now see if we are compatible
- with existing bindings *)
- function new_tin ->
- let x = Ast_cocci.unwrap_mcode name in
- (match
- check_add_metavars_binding false keep inherited (x, pvalu)
- new_tin with
- | Some binding ->
- f () {new_tin with binding = binding}
- | None -> fail tin))
- new_tin
- | Ast_cocci.NoMetaPos -> f () new_tin)
- | None -> fail tin
-
- (* ------------------------------------------------------------------------*)
- (* Environment, allbounds *)
- (* ------------------------------------------------------------------------*)
- (* all referenced inherited variables have to be bound. This would
- * be naturally checked for the minus or context ones in the
- * matching process, but have to check the plus ones as well. The
- * result of get_inherited contains all of these, but the potential
- * redundant checking for the minus and context ones is probably not
- * a big deal. If it's a problem, could fix free_vars to distinguish
- * between + variables and the other ones. *)
-
- let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
- l +> List.for_all (fun inhvar ->
- match Common.optionise (fun () -> tin.binding0 +> List.assoc inhvar) with
- | Some _ -> true
- | None -> false
- )
-
- let optional_storage_flag f = fun tin ->
- f (tin.extra.optional_storage_iso) tin
-
- let optional_qualifier_flag f = fun tin ->
- f (tin.extra.optional_qualifier_iso) tin
-
- let value_format_flag f = fun tin ->
- f (tin.extra.value_format_iso) tin
-
-
- (* ------------------------------------------------------------------------*)
- (* Tokens *)
- (* ------------------------------------------------------------------------*)
- let tokenf ia ib = fun tin ->
- let pos = Ast_c.info_to_fixpos ib in
- let posmck = Ast_cocci.FixPos (pos, pos) in
- let finish tin = tag_mck_pos_mcode ia posmck ib tin in
- match Ast_cocci.get_pos_var ia with
- Ast_cocci.MetaPos(name,constraints,per,keep,inherited) ->
- let mpos = Lib_parsing_c.lin_col_by_pos [ib] in
- let pvalu = Ast_c.MetaPosValList [mpos] in
- check_pos_constraints constraints pvalu
- (function () ->
- (* constraints are satisfied, now see if we are compatible
- with existing bindings *)
- function new_tin ->
- let x = Ast_cocci.unwrap_mcode name in
- (match
- check_add_metavars_binding false keep inherited (x, pvalu) tin
- with
- Some binding -> finish {tin with binding = binding}
- | None -> fail tin))
- tin
- | _ -> finish tin
-
- let tokenf_mck mck ib = fun tin ->
- let pos = Ast_c.info_to_fixpos ib in
- let posmck = Ast_cocci.FixPos (pos, pos) in
- [(tag_mck_pos mck posmck, ib), tin.binding]
-
-end
-
-(*****************************************************************************)
-(* Entry point *)
-(*****************************************************************************)
-module MATCH = Cocci_vs_c.COCCI_VS_C (XMATCH)
-
-
-let match_re_node2 dropped_isos a b binding0 =
-
- let tin = {
- XMATCH.extra = {
- optional_storage_iso = not(List.mem "optional_storage" dropped_isos);
- optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
- value_format_iso = not(List.mem "value_format" dropped_isos);
- };
- XMATCH.binding = [];
- XMATCH.binding0 = binding0;
- } in
-
- MATCH.rule_elem_node a b tin
- (* take only the tagged-SP, the 'a' *)
- +> List.map (fun ((a,_b), binding) -> a, binding)
-
-
-let match_re_node a b c d =
- Common.profile_code "Pattern3.match_re_node"
- (fun () -> match_re_node2 a b c d)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common.Infix
-
-open Lib_engine
-
-
-let pp = Common.pp
-
-let pp_meta (_,x) = pp x
-
-let rec pp_binding_kind = function
- | Ast_c.MetaIdVal s -> pp ("id " ^ s)
- | Ast_c.MetaFuncVal s -> pp ("func " ^ s)
- | Ast_c.MetaLocalFuncVal s -> pp ("localfunc " ^ s)
- | Ast_c.MetaExprVal expr ->
- Pretty_print_c.pp_expression_simple expr
- | Ast_c.MetaExprListVal expr_list -> pp "<<exprlist>>"
- | Ast_c.MetaTypeVal typ ->
- Pretty_print_c.pp_type_simple typ
- | Ast_c.MetaStmtVal statement ->
- Pretty_print_c.pp_statement_simple statement
- | Ast_c.MetaParamVal params -> pp "<<param>>"
- | Ast_c.MetaParamListVal params -> pp "<<paramlist>>"
- | Ast_c.MetaListlenVal n -> pp (string_of_int n)
- | Ast_c.MetaPosVal (pos1, pos2) ->
- let print_pos = function
- Ast_cocci.Real x -> string_of_int x
- | Ast_cocci.Virt(x,off) -> Printf.sprintf "%d+%d" x off in
- pp (Common.sprintf ("pos(%s,%s)") (print_pos pos1) (print_pos pos2))
- | Ast_c.MetaPosValList l ->
- pp (Common.sprintf ("poss[%s]")
- (String.concat ", "
- (List.map
- (function (fl,ce,(minl,minc),(maxl,maxc)) ->
- Printf.sprintf "(%s,%s,(%d,%d),(%d,%d))"
- fl ce minl minc maxl maxc)
- l)))
-
-and pp_binding subst =
- begin
- pp "[";
- Common.print_between (fun () -> pp ";"; Format.print_cut() )
- (fun ((_,s), kind) -> pp s; pp " --> "; pp_binding_kind kind)
- subst;
- pp "]";
- end
-
-
-let pp_binding_kind2 = function
- | ParenVal s -> pp "pv("; pp_meta s; pp ")"
- | NormalMetaVal x -> pp_binding_kind x
- | LabelVal xs ->
- begin
- pp "labelval";
- pp "(";
- Common.print_between (fun () -> pp ",") Format.print_int xs;
- pp ")";
- end
- | GoodVal -> pp "goodval"
- | BadVal -> pp "badval"
-
-
-let rec pp_predicate = function
- | InLoop -> pp "InLoop"
- | TrueBranch -> pp "TrueBranch"
- | FalseBranch -> pp "FalseBranch"
- | After -> pp "After"
- | FallThrough -> pp "FallThrough"
- | Return -> pp "Return"
- | FunHeader -> pp "FunHeader"
- | Top -> pp "Top"
- | ErrorExit -> pp "ErrorExit"
- | Exit -> pp "Exit"
- | Goto -> pp "Goto"
- | Paren s -> pp "Paren("; pp_meta s; pp ")"
- | Match (re) -> Pretty_print_cocci.print_rule_elem re
- | Label s -> pp "Label("; pp_meta s; pp ")"
- | BCLabel s -> pp "BreakContinueLabel("; pp_meta s; pp ")"
- | PrefixLabel s -> pp "PrefixLabel("; pp_meta s; pp ")"
- | BindGood s -> pp "BindGood("; pp_meta s; pp ")"
- | BindBad s -> pp "BindBad("; pp_meta s; pp ")"
- | FakeBrace -> pp "FakeBrace"
-
-and pp_binding2 subst =
- begin
- pp "[";
- Common.print_between (fun () -> pp ";";Format.print_cut(); )
- (fun (s, kind) -> pp s; pp " --> "; pp_binding_kind2 kind)
- subst;
- pp "]";
- end
-
-and pp_binding2_ctlsubst subst =
- begin
- pp "[";
- Common.print_between (fun () -> pp ";"; Format.print_cut(); )
- (function
- Ast_ctl.Subst (s, kind) ->
- pp_meta s; pp " --> "; pp_binding_kind2 kind;
- | Ast_ctl.NegSubst (s, kind) ->
- pp_meta s; pp " -/-> "; pp_binding_kind2 kind;
- )
- subst;
- pp "]";
- end
-
-let predicate_to_string pred =
- Common.format_to_string (function _ -> pp_predicate pred)
-
-
-let pp_pred_smodif = fun (pred, smodif) ->
- begin
- pp_predicate pred;
-(*
- (match smodif with
- | Ast_ctl.Modif x | Ast_ctl.UnModif x -> pp " with <modifTODO>"
- | Ast_ctl.Control -> ()
- )
-*)
- end
-
-
-let pp_ctlcocci show_plus inline_let_def ctl =
- begin
- if show_plus
- then begin
- Pretty_print_cocci.print_plus_flag := true;
- Pretty_print_cocci.print_minus_flag := true;
- end
- else begin
- Pretty_print_cocci.print_plus_flag := false;
- Pretty_print_cocci.print_minus_flag := false;
- end;
- Common.pp_do_in_box (fun () ->
- Pretty_print_ctl.pp_ctl (pp_pred_smodif,(fun s -> pp_meta s))
- inline_let_def ctl;
- );
- end
-
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Common
-
-module F = Control_flow_c
-
-(*****************************************************************************)
-(* The functor argument *)
-(*****************************************************************************)
-
-(* info passed recursively in monad in addition to binding *)
-type xinfo = {
- optional_storage_iso : bool;
- optional_qualifier_iso : bool;
- value_format_iso : bool;
- current_rule_name : string; (* used for errors *)
-}
-
-module XTRANS = struct
-
- (* ------------------------------------------------------------------------*)
- (* Combinators history *)
- (* ------------------------------------------------------------------------*)
- (*
- * version0:
- * type ('a, 'b) transformer =
- * 'a -> 'b -> Lib_engine.metavars_binding -> 'b
- * exception NoMatch
- *
- * version1:
- * type ('a, 'b) transformer =
- * 'a -> 'b -> Lib_engine.metavars_binding -> 'b option
- * use an exception monad
- *
- * version2:
- * type tin = Lib_engine.metavars_binding
- *)
-
- (* ------------------------------------------------------------------------*)
- (* Standard type and operators *)
- (* ------------------------------------------------------------------------*)
-
- type tin = {
- extra: xinfo;
- binding: Lib_engine.metavars_binding;
- binding0: Lib_engine.metavars_binding; (* inherited variable *)
- }
- type 'x tout = 'x option
-
- type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
-
- let (>>=) m f = fun tin ->
- match m tin with
- | None -> None
- | Some (a,b) -> f a b tin
-
- let return = fun x -> fun tin ->
- Some x
-
- (* can have fail in transform now that the process is deterministic ? *)
- let fail = fun tin ->
- None
-
- let (>||>) m1 m2 = fun tin ->
- match m1 tin with
- | None -> m2 tin
- | Some x -> Some x (* stop as soon as have found something *)
-
- let (>|+|>) m1 m2 = m1 >||> m2
-
- let (>&&>) f m = fun tin ->
- if f tin then m tin else fail tin
-
- let optional_storage_flag f = fun tin ->
- f (tin.extra.optional_storage_iso) tin
-
- let optional_qualifier_flag f = fun tin ->
- f (tin.extra.optional_qualifier_iso) tin
-
- let value_format_flag f = fun tin ->
- f (tin.extra.value_format_iso) tin
-
- let mode = Cocci_vs_c.TransformMode
-
- (* ------------------------------------------------------------------------*)
- (* Exp *)
- (* ------------------------------------------------------------------------*)
- let cocciExp = fun expf expa node -> fun tin ->
-
- let bigf = {
- Visitor_c.default_visitor_c_s with
- Visitor_c.kexpr_s = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | None -> (* failed *) k expb
- | Some (x, expb) -> expb);
- }
- in
- Some (expa, Visitor_c.vk_node_s bigf node)
-
-
- (* same as cocciExp, but for expressions in an expression, not expressions
- in a node *)
- let cocciExpExp = fun expf expa expb -> fun tin ->
-
- let bigf = {
- Visitor_c.default_visitor_c_s with
- Visitor_c.kexpr_s = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | None -> (* failed *) k expb
- | Some (x, expb) -> expb);
- }
- in
- Some (expa, Visitor_c.vk_expr_s bigf expb)
-
-
- let cocciTy = fun expf expa node -> fun tin ->
-
- let bigf = {
- Visitor_c.default_visitor_c_s with
- Visitor_c.ktype_s = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | None -> (* failed *) k expb
- | Some (x, expb) -> expb);
- }
- in
- Some (expa, Visitor_c.vk_node_s bigf node)
-
- let cocciInit = fun expf expa node -> fun tin ->
-
- let bigf = {
- Visitor_c.default_visitor_c_s with
- Visitor_c.kini_s = (fun (k, bigf) expb ->
- match expf expa expb tin with
- | None -> (* failed *) k expb
- | Some (x, expb) -> expb);
- }
- in
- Some (expa, Visitor_c.vk_node_s bigf node)
-
-
- (* ------------------------------------------------------------------------*)
- (* Tokens *)
- (* ------------------------------------------------------------------------*)
- let check_pos info mck pos =
- match mck with
- | Ast_cocci.PLUS -> raise Impossible
- | Ast_cocci.CONTEXT (Ast_cocci.FixPos (i1,i2),_)
- | Ast_cocci.MINUS (Ast_cocci.FixPos (i1,i2),_) ->
- pos <= i2 && pos >= i1
- | Ast_cocci.CONTEXT (Ast_cocci.DontCarePos,_)
- | Ast_cocci.MINUS (Ast_cocci.DontCarePos,_) ->
- true
- | _ ->
- match info with
- Some info ->
- failwith
- (Printf.sprintf
- "wierd: dont have position info for the mcodekind in line %d column %d"
- info.Ast_cocci.line info.Ast_cocci.column)
- | None ->
- failwith "wierd: dont have position info for the mcodekind"
-
-
- let tag_with_mck mck ib = fun tin ->
-
- let cocciinforef = ib.Ast_c.cocci_tag in
- let (oldmcode, oldenv) = !cocciinforef in
-
- let mck =
- (* coccionly:
- if !Flag_parsing_cocci.sgrep_mode
- then Sgrep.process_sgrep ib mck
- else
- *)
- mck
- in
- (match mck, Ast_c.pinfo_of_info ib with
- | _, Ast_c.AbstractLineTok _ -> raise Impossible
- | Ast_cocci.MINUS(_), Ast_c.ExpandedTok _ ->
- failwith ("try to delete an expanded token: " ^ (Ast_c.str_of_info ib))
- | _ -> ()
- );
-
- match (oldmcode,mck) with
- | (Ast_cocci.CONTEXT(_,Ast_cocci.NOTHING), _)
- | (_, Ast_cocci.CONTEXT(_,Ast_cocci.NOTHING))
- ->
- cocciinforef := (mck, tin.binding);
- ib
-
- | _ ->
- if (oldmcode, oldenv) = (mck, tin.binding)
- then begin
- if !Flag_matcher.show_misc
- then pr2 "already tagged but with same mcode, so safe";
- ib
- end
- else
- (* coccionly:
- if !Flag.sgrep_mode2
- then ib (* safe *)
- else
- *)
- begin
- (* coccionly:
- Format.set_formatter_out_channel stderr;
- Common.pr2 "SP mcode ";
- Pretty_print_cocci.print_mcodekind oldmcode;
- Format.print_newline();
- Common.pr2 "C code mcode ";
- Pretty_print_cocci.print_mcodekind mck;
- Format.print_newline();
- Format.print_flush();
- *)
- failwith
- (Common.sprintf "%s: already tagged token:\n%s"
- tin.extra.current_rule_name
- (Common.error_message (Ast_c.file_of_info ib)
- (Ast_c.str_of_info ib, Ast_c.opos_of_info ib)))
- end
-
- let tokenf ia ib = fun tin ->
- let (_,i,mck,_) = ia in
- let pos = Ast_c.info_to_fixpos ib in
- if check_pos (Some i) mck pos
- then return (ia, tag_with_mck mck ib tin) tin
- else fail tin
-
- let tokenf_mck mck ib = fun tin ->
- let pos = Ast_c.info_to_fixpos ib in
- if check_pos None mck pos
- then return (mck, tag_with_mck mck ib tin) tin
- else fail tin
-
-
- (* ------------------------------------------------------------------------*)
- (* Distribute mcode *)
- (* ------------------------------------------------------------------------*)
-
- (* When in the SP we attach something to a metavariable, or delete it, as in
- * - S
- * + foo();
- * we have to minusize all the token that compose S in the C code, and
- * attach the 'foo();' to the right token, the one at the very right.
- *)
-
- type 'a distributer =
- (Ast_c.info -> Ast_c.info) * (* what to do on left *)
- (Ast_c.info -> Ast_c.info) * (* what to do on middle *)
- (Ast_c.info -> Ast_c.info) * (* what to do on right *)
- (Ast_c.info -> Ast_c.info) -> (* what to do on both *)
- 'a -> 'a
-
- let distribute_mck mcodekind distributef expr tin =
- match mcodekind with
- | Ast_cocci.MINUS (pos,any_xxs) ->
- distributef (
- (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,any_xxs)) ib tin),
- (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,[])) ib tin),
- (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,[])) ib tin),
- (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,any_xxs)) ib tin)
- ) expr
- | Ast_cocci.CONTEXT (pos,any_befaft) ->
- (match any_befaft with
- | Ast_cocci.NOTHING -> expr
-
- | Ast_cocci.BEFORE xxs ->
- distributef (
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFORE xxs)) ib tin),
- (fun x -> x),
- (fun x -> x),
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFORE xxs)) ib tin)
- ) expr
- | Ast_cocci.AFTER xxs ->
- distributef (
- (fun x -> x),
- (fun x -> x),
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.AFTER xxs)) ib tin),
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.AFTER xxs)) ib tin)
- ) expr
-
- | Ast_cocci.BEFOREAFTER (xxs, yys) ->
- distributef (
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFORE xxs)) ib tin),
- (fun x -> x),
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.AFTER yys)) ib tin),
- (fun ib -> tag_with_mck
- (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFOREAFTER (xxs,yys)))
- ib tin)
- ) expr
-
- )
- | Ast_cocci.PLUS -> raise Impossible
-
-
- (* use new strategy, collect ii, sort, recollect and tag *)
-
- let mk_bigf (maxpos, minpos) (lop,mop,rop,bop) =
- let bigf = {
- Visitor_c.default_visitor_c_s with
- Visitor_c.kinfo_s = (fun (k,bigf) i ->
- let pos = Ast_c.info_to_fixpos i in
- match () with
- | _ when Ast_cocci.equal_pos pos maxpos &&
- Ast_cocci.equal_pos pos minpos -> bop i
- | _ when Ast_cocci.equal_pos pos maxpos -> rop i
- | _ when Ast_cocci.equal_pos pos minpos -> lop i
- | _ -> mop i
- )
- } in
- bigf
-
- let distribute_mck_expr (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
- Visitor_c.vk_expr_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
-
- let distribute_mck_args (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
- Visitor_c.vk_args_splitted_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
-
- let distribute_mck_type (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
- Visitor_c.vk_type_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
-
- let distribute_mck_ini (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
- Visitor_c.vk_ini_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
-
- let distribute_mck_param (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
- Visitor_c.vk_param_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
-
- let distribute_mck_params (maxpos, minpos) = fun (lop,mop,rop,bop) ->fun x ->
- Visitor_c.vk_params_splitted_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
- x
-
- let distribute_mck_node (maxpos, minpos) = fun (lop,mop,rop,bop) ->fun x ->
- Visitor_c.vk_node_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
- x
-
- let distribute_mck_struct_fields (maxpos, minpos) =
- fun (lop,mop,rop,bop) ->fun x ->
- Visitor_c.vk_struct_fields_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
- x
-
- let distribute_mck_cst (maxpos, minpos) =
- fun (lop,mop,rop,bop) ->fun x ->
- Visitor_c.vk_cst_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
- x
-
-
- let distribute_mck_define_params (maxpos, minpos) = fun (lop,mop,rop,bop) ->
- fun x ->
- Visitor_c.vk_define_params_splitted_s
- (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
- x
-
- let get_pos mck =
- match mck with
- | Ast_cocci.PLUS -> raise Impossible
- | Ast_cocci.CONTEXT (Ast_cocci.FixPos (i1,i2),_)
- | Ast_cocci.MINUS (Ast_cocci.FixPos (i1,i2),_) ->
- Ast_cocci.FixPos (i1,i2)
- | Ast_cocci.CONTEXT (Ast_cocci.DontCarePos,_)
- | Ast_cocci.MINUS (Ast_cocci.DontCarePos,_) ->
- Ast_cocci.DontCarePos
- | _ -> failwith "wierd: dont have position info for the mcodekind"
-
- let distrf (ii_of_x_f, distribute_mck_x_f) =
- fun ia x -> fun tin ->
- let mck = Ast_cocci.get_mcodekind ia in
- let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
- in
- if
- (* bug: check_pos mck max && check_pos mck min
- *
- * if do that then if have - f(...); and in C f(1,2); then we
- * would get a "already tagged" because the '...' would sucess in
- * transformaing both '1' and '1,2'. So being in the range is not
- * enough. We must be equal exactly to the range!
- *)
- (match get_pos mck with
- | Ast_cocci.DontCarePos -> true
- | Ast_cocci.FixPos (i1, i2) ->
- i1 = min && i2 = max
- | _ -> raise Impossible
- )
-
- then
- return (
- ia,
- distribute_mck mck (distribute_mck_x_f (max,min)) x tin
- ) tin
- else fail tin
-
-
- let distrf_e = distrf (Lib_parsing_c.ii_of_expr, distribute_mck_expr)
- let distrf_args = distrf (Lib_parsing_c.ii_of_args, distribute_mck_args)
- let distrf_type = distrf (Lib_parsing_c.ii_of_type, distribute_mck_type)
- let distrf_param = distrf (Lib_parsing_c.ii_of_param, distribute_mck_param)
- let distrf_params = distrf (Lib_parsing_c.ii_of_params,distribute_mck_params)
- let distrf_ini = distrf (Lib_parsing_c.ii_of_ini,distribute_mck_ini)
- let distrf_node = distrf (Lib_parsing_c.ii_of_node,distribute_mck_node)
- let distrf_struct_fields =
- distrf (Lib_parsing_c.ii_of_struct_fields, distribute_mck_struct_fields)
- let distrf_cst =
- distrf (Lib_parsing_c.ii_of_cst, distribute_mck_cst)
- let distrf_define_params =
- distrf (Lib_parsing_c.ii_of_define_params,distribute_mck_define_params)
-
-
- (* ------------------------------------------------------------------------*)
- (* Environment *)
- (* ------------------------------------------------------------------------*)
- let meta_name_to_str (s1, s2) =
- s1 ^ "." ^ s2
-
- let envf keep _inherited = fun (s, value, _) f tin ->
- let s = Ast_cocci.unwrap_mcode s in
- let v =
- if keep = Type_cocci.Saved
- then (
- try Some (List.assoc s tin.binding)
- with Not_found ->
- pr2(sprintf
- "Don't find value for metavariable %s in the environment"
- (meta_name_to_str s));
- None)
- else
- (* not raise Impossible! *)
- Some (value)
- in
- match v with
- | None -> fail tin
- | Some (value') ->
-
- (* Ex: in cocci_vs_c someone wants to add a binding. Here in
- * transformation3 the value for this var may be already in the
- * env, because for instance its value were fixed in a previous
- * SmPL rule. So here we want to check that this is the same value.
- * If forget to do the check, what can happen ? Because of Exp
- * and other disjunctive feature of cocci_vs_c (>||>), we
- * may accept a match at a wrong position. Maybe later this
- * will be detected via the pos system on tokens, but maybe
- * not. So safer to keep the check.
- *)
-
- (*f () tin*)
- if Cocci_vs_c.equal_metavarval value value'
- then f () tin
- else fail tin
-
-
- let check_constraints matcher constraints exp = fun f tin -> f () tin
-
- (* ------------------------------------------------------------------------*)
- (* Environment, allbounds *)
- (* ------------------------------------------------------------------------*)
- let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
- true (* in transform we don't care ? *)
-
-end
-
-(*****************************************************************************)
-(* Entry point *)
-(*****************************************************************************)
-module TRANS = Cocci_vs_c.COCCI_VS_C (XTRANS)
-
-
-let transform_re_node a b tin =
- match TRANS.rule_elem_node a b tin with
- | None -> raise Impossible
- | Some (_sp, b') -> b'
-
-let (transform2: string (* rule name *) -> string list (* dropped_isos *) ->
- Lib_engine.metavars_binding (* inherited bindings *) ->
- Lib_engine.transformation_info -> F.cflow -> F.cflow) =
- fun rule_name dropped_isos binding0 xs cflow ->
-
- let extra = {
- optional_storage_iso = not(List.mem "optional_storage" dropped_isos);
- optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
- value_format_iso = not(List.mem "value_format" dropped_isos);
- current_rule_name = rule_name;
- } in
-
- (* find the node, transform, update the node, and iter for all elements *)
-
- xs +> List.fold_left (fun acc (nodei, binding, rule_elem) ->
- (* subtil: not cflow#nodes but acc#nodes *)
- let node = acc#nodes#assoc nodei in
-
- if !Flag.show_transinfo
- then pr2 "transform one node";
-
- let tin = {
- XTRANS.extra = extra;
- XTRANS.binding = binding0@binding;
- XTRANS.binding0 = []; (* not used - everything constant for trans *)
- } in
-
- let node' = transform_re_node rule_elem node tin in
-
- (* assert that have done something. But with metaruleElem sometimes
- dont modify fake nodes. So special case before on Fake nodes. *)
- (match F.unwrap node with
- | F.Enter | F.Exit | F.ErrorExit
- | F.EndStatement _ | F.CaseNode _
- | F.Fake
- | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
- -> ()
- | _ -> () (* assert (not (node =*= node')); *)
- );
-
- (* useless, we dont go back from flow to ast now *)
- (* let node' = lastfix_comma_struct node' in *)
-
- acc#replace_node (nodei, node');
- acc
- ) cflow
-
-
-
-let transform a b c d e =
- Common.profile_code "Transformation3.transform"
- (fun () -> transform2 a b c d e)
-let version = "0.1.6"
+let version = "0.1.6a"
let path =
try (Sys.getenv "COCCINELLE_HOME")
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-TARGET=cocci_parser
-
-LEXER_SOURCES = lexer_cocci.mll
-SCRIPT_LEXER_SOURCES = lexer_script.mll
-PARSER_SOURCES = parser_cocci_menhir.mly
-SOURCES = flag_parsing_cocci.ml type_cocci.ml ast_cocci.ml ast0_cocci.ml \
-pretty_print_cocci.ml unparse_ast0.ml \
-visitor_ast.ml visitor_ast0.ml compute_lines.ml comm_assoc.ml \
-iso_pattern.ml iso_compile.ml single_statement.ml simple_assignments.ml \
-ast0toast.ml check_meta.ml top_level.ml type_infer.ml test_exps.ml \
-unitary_ast0.ml arity.ml index.ml context_neg.ml \
-insert_plus.ml function_prototypes.ml \
-unify_ast.ml semantic_cocci.ml data.ml free_vars.ml parse_aux.ml disjdistr.ml \
-$(LEXER_SOURCES:.mll=.ml) $(PARSER_SOURCES:.mly=.ml) \
-$(SCRIPT_LEXER_SOURCES:.mll=.ml) \
-get_constants.ml get_constants2.ml parse_cocci.ml
-
-LIBS=../commons/commons.cma ../globals/globals.cma
-SYSLIBS = str.cma unix.cma
-
-#MENHIR_PATH=$(shell ocamlfind query menhirLib)
-MENHIR_PATH=../menhirlib
-
-INCLUDES = -I ../commons -I ../commons/ocamlextra -I ../globals \
--I $(MENHIR_PATH)
-
-MENHIR=$(MENHIR_PATH)/menhirLib.cmo
-MENHIRO=$(MENHIR_PATH)/menhirLib.cmx
-
-
-# The Caml compilers.
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX = ocamllex$(OPTBIN)
-OCAMLYACC= menhir --table
-OCAMLDEP = ocamldep$(OPTBIN) #$(INCLUDES)
-EXEC=$(TARGET).byte
-EXEC=$(TARGET)
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-GENERATED= $(LEXER_SOURCES:.mll=.ml) $(SCRIPT_LEXER_SOURCES:.mll=.ml) \
- $(PARSER_SOURCES:.mly=.ml) $(PARSER_SOURCES:.mly=.mli)
-OBJS = $(SOURCES:.ml=.cmo)
-OPTOBJS = $(OBJS:.cmo=.cmx)
-
-
-all: $(LIB)
-local: $(EXEC)
-
-all.opt: $(OPTLIB)
-
-$(LIB): $(GENERATED) $(OBJS)
- $(OCAMLC) -I $(MENHIR_PATH) -a -o $(LIB) $(MENHIR) $(OBJS)
-
-
-$(OPTLIB): $(GENERATED) $(OPTOBJS)
- $(OCAMLOPT) -I $(MENHIR_PATH) -a -o $(OPTLIB) $(MENHIRO) $(OPTOBJS)
-
-
-$(EXEC): $(OBJS) main.cmo $(LIBS)
- $(OCAMLC) -o $(EXEC) $(SYSLIBS) $(LIBS) $(OBJS) main.cmo
-
-
-
-
-clean::
- rm -f $(LIB)
- rm -f $(OPTLIB) $(LIB:.cma=.a)
- rm -f $(TARGET)
-
-
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-$(LEXER_SOURCES:.mll=.ml) : $(LEXER_SOURCES)
- $(OCAMLLEX) $(LEXER_SOURCES)
-
-$(PARSER_SOURCES:.mly=.ml) $(PARSER_SOURCES:.mly=.mli) : $(PARSER_SOURCES)
- $(OCAMLYACC) $(PARSER_SOURCES)
-
-$(SCRIPT_LEXER_SOURCES:.mll=.ml): $(SCRIPT_LEXER_SOURCES)
- $(OCAMLLEX) $(SCRIPT_LEXER_SOURCES)
-
-clean::
- rm -f $(GENERATED)
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend: $(GENERATED)
- $(OCAMLDEP) *.mli *.ml > .depend
-
-.depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
-
-lexer_cocci.ml: lexer_cocci.mll
-parser_cocci_menhir.ml: parser_cocci_menhir.mly lexer_cocci.mll
-parser_cocci_menhir.mli: parser_cocci_menhir.mly lexer_cocci.mll
-lexer_script.ml: lexer_script.mll
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-TARGET=cocci_parser
-
-LEXER_SOURCES = lexer_cocci.mll
-SCRIPT_LEXER_SOURCES = lexer_script.mll
-PARSER_SOURCES = parser_cocci_menhir.mly
-SOURCES = flag_parsing_cocci.ml type_cocci.ml ast_cocci.ml ast0_cocci.ml \
-pretty_print_cocci.ml unparse_ast0.ml \
-visitor_ast.ml visitor_ast0.ml compute_lines.ml comm_assoc.ml \
-iso_pattern.ml iso_compile.ml single_statement.ml simple_assignments.ml \
-ast0toast.ml check_meta.ml top_level.ml type_infer.ml test_exps.ml \
-unitary_ast0.ml arity.ml index.ml context_neg.ml \
-insert_plus.ml function_prototypes.ml \
-unify_ast.ml semantic_cocci.ml data.ml free_vars.ml parse_aux.ml disjdistr.ml \
-$(LEXER_SOURCES:.mll=.ml) $(PARSER_SOURCES:.mly=.ml) \
-$(SCRIPT_LEXER_SOURCES:.mll=.ml) \
-get_constants.ml get_constants2.ml parse_cocci.ml
-
-LIBS=../commons/commons.cma ../globals/globals.cma
-SYSLIBS = str.cma unix.cma
-
-#MENHIR_PATH=$(shell ocamlfind query menhirLib)
-MENHIR_PATH=../menhirlib
-
-INCLUDES = -I ../commons -I ../commons/ocamlextra -I ../globals \
--I $(MENHIR_PATH)
-
-MENHIR=$(MENHIR_PATH)/menhirLib.cmo
-MENHIRO=$(MENHIR_PATH)/menhirLib.cmx
-
-
-# The Caml compilers.
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLLEX = ocamllex$(OPTBIN)
-OCAMLYACC= menhir --table
-OCAMLDEP = ocamldep$(OPTBIN) $(INCLUDES)
-EXEC=$(TARGET).byte
-EXEC=$(TARGET)
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-GENERATED= $(LEXER_SOURCES:.mll=.ml) $(SCRIPT_LEXER_SOURCES:.mll=.ml) \
- $(PARSER_SOURCES:.mly=.ml) $(PARSER_SOURCES:.mly=.mli)
-OBJS = $(SOURCES:.ml=.cmo)
-OPTOBJS = $(OBJS:.cmo=.cmx)
-
-
-all: $(LIB)
-local: $(EXEC)
-
-all.opt: $(OPTLIB)
-
-$(LIB): $(GENERATED) $(OBJS)
- $(OCAMLC) -I $(MENHIR_PATH) -a -o $(LIB) $(MENHIR) $(OBJS)
-
-
-$(OPTLIB): $(GENERATED) $(OPTOBJS)
- $(OCAMLOPT) -I $(MENHIR_PATH) -a -o $(OPTLIB) $(MENHIRO) $(OPTOBJS)
-
-
-$(EXEC): $(OBJS) main.cmo $(LIBS)
- $(OCAMLC) -o $(EXEC) $(SYSLIBS) $(LIBS) $(OBJS) main.cmo
-
-
-
-
-clean::
- rm -f $(LIB)
- rm -f $(OPTLIB) $(LIB:.cma=.a)
- rm -f $(TARGET)
-
-
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-$(LEXER_SOURCES:.mll=.ml) : $(LEXER_SOURCES)
- $(OCAMLLEX) $(LEXER_SOURCES)
-
-$(PARSER_SOURCES:.mly=.ml) $(PARSER_SOURCES:.mly=.mli) : $(PARSER_SOURCES)
- $(OCAMLYACC) $(PARSER_SOURCES)
-
-$(SCRIPT_LEXER_SOURCES:.mll=.ml): $(SCRIPT_LEXER_SOURCES)
- $(OCAMLLEX) $(SCRIPT_LEXER_SOURCES)
-
-clean::
- rm -f $(GENERATED)
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend: $(GENERATED)
- $(OCAMLDEP) *.mli *.ml > .depend
-
-.depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
-
-lexer_cocci.ml: lexer_cocci.mll
-parser_cocci_menhir.ml: parser_cocci_menhir.mly lexer_cocci.mll
-parser_cocci_menhir.mli: parser_cocci_menhir.mly lexer_cocci.mll
-lexer_script.ml: lexer_script.mll
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Arities matter for the minus slice, but not for the plus slice. *)
-
-(* ? only allowed on rule_elems, and on subterms if the context is ? also. *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-
-let warning s = Printf.printf "warning: %s\n" s
-
-let fail w str =
- failwith
- (Printf.sprintf "cocci line %d: %s" ((Ast0.get_info w).Ast0.line_start)
- str)
-
-let make_opt_unique optfn uniquefn info tgt arity term =
- let term = Ast0.rewrap info term in
- if tgt = arity
- then term
- else (* tgt must be NONE *)
- match arity with
- Ast0.OPT -> Ast0.copywrap info (optfn term)
- | Ast0.UNIQUE -> Ast0.copywrap info (uniquefn term)
- | Ast0.NONE -> failwith "tgt must be NONE"
-
-let all_same opt_allowed tgt line arities =
- let tgt =
- match tgt with
- Ast0.NONE ->
- (match List.hd arities with
- Ast0.OPT when not opt_allowed ->
- failwith "opt only allowed for the elements of a statement list"
- | x -> x)
- | _ -> tgt in
- if not(List.for_all (function x -> x = tgt) arities)
- then warning (Printf.sprintf "incompatible arity found on line %d" line);
- tgt
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-let anyopt l fn = List.exists (function w -> fn(Ast0.unwrap w)) l
-
-let allopt l fn =
- let rec loop = function
- [] -> []
- | x::xs ->
- match fn (Ast0.unwrap x) with
- Some x -> x :: (loop xs)
- | None -> [] in
- let res = loop l in
- if List.length res = List.length l then Some res else None
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Mcode *)
-
-let mcode2line (_,_,info,_,_) = info.Ast0.line_start
-let mcode2arity (_,arity,_,_,_) = arity
-
-let mcode x = x (* nothing to do ... *)
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots fn d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(x) -> Ast0.DOTS(List.map fn x)
- | Ast0.CIRCLES(x) -> Ast0.CIRCLES(List.map fn x)
- | Ast0.STARS(x) -> Ast0.STARS(List.map fn x))
-
-let only_dots l =
- not
- (List.exists
- (function x ->
- match Ast0.unwrap x with
- Ast0.Circles(_,_) | Ast0.Stars(_,_) -> true
- | _ -> false)
- l)
-
-let only_circles l =
- not (List.exists
- (function x ->
- match Ast0.unwrap x with
- Ast0.Dots(_,_) | Ast0.Stars(_,_) -> true
- | _ -> false)
- l)
-
-let only_stars l =
- not (List.exists
- (function x ->
- match Ast0.unwrap x with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) -> true
- | _ -> false)
- l)
-
-let concat_dots fn d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(x) ->
- let l = List.map fn x in
- if only_dots l
- then Ast0.DOTS(l)
- else fail d "inconsistent dots usage"
- | Ast0.CIRCLES(x) ->
- let l = List.map fn x in
- if only_circles l
- then Ast0.CIRCLES(l)
- else fail d "inconsistent dots usage"
- | Ast0.STARS(x) ->
- let l = List.map fn x in
- if only_stars l
- then Ast0.STARS(l)
- else fail d "inconsistent dots usage")
-
-let flat_concat_dots fn d =
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> List.map fn x
- | Ast0.CIRCLES(x) -> List.map fn x
- | Ast0.STARS(x) -> List.map fn x
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let make_id =
- make_opt_unique
- (function x -> Ast0.OptIdent x)
- (function x -> Ast0.UniqueIdent x)
-
-let ident opt_allowed tgt i =
- match Ast0.unwrap i with
- Ast0.Id(name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.Id(name))
- | Ast0.MetaId(name,constraints,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.MetaId(name,constraints,pure))
- | Ast0.MetaFunc(name,constraints,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.MetaFunc(name,constraints,pure))
- | Ast0.MetaLocalFunc(name,constraints,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.MetaLocalFunc(name,constraints,pure))
- | Ast0.OptIdent(_) | Ast0.UniqueIdent(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let make_exp =
- make_opt_unique
- (function x -> Ast0.OptExp x)
- (function x -> Ast0.UniqueExp x)
-
-let rec top_expression opt_allowed tgt expr =
- let exp_same = all_same opt_allowed tgt in
- match Ast0.unwrap expr with
- Ast0.Ident(id) ->
- let new_id = ident opt_allowed tgt id in
- Ast0.rewrap expr
- (match Ast0.unwrap new_id with
- Ast0.OptIdent(id) ->
- Ast0.OptExp(Ast0.rewrap expr (Ast0.Ident(id)))
- | Ast0.UniqueIdent(id) ->
- Ast0.UniqueExp(Ast0.rewrap expr (Ast0.Ident(id)))
- | _ -> Ast0.Ident(new_id))
- | Ast0.Constant(const) ->
- let arity = exp_same (mcode2line const) [mcode2arity const] in
- let const = mcode const in
- make_exp expr tgt arity (Ast0.Constant(const))
- | Ast0.FunCall(fn,lp,args,rp) ->
- let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let fn = expression arity fn in
- let lp = mcode lp in
- let args = dots (expression arity) args in
- let rp = mcode rp in
- make_exp expr tgt arity (Ast0.FunCall(fn,lp,args,rp))
- | Ast0.Assignment(left,op,right,simple) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let left = expression arity left in
- let op = mcode op in
- let right = expression arity right in
- make_exp expr tgt arity (Ast0.Assignment(left,op,right,simple))
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- let arity =
- exp_same (mcode2line why) [mcode2arity why; mcode2arity colon] in
- let exp1 = expression arity exp1 in
- let why = mcode why in
- let exp2 = get_option (expression arity) exp2 in
- let colon = mcode colon in
- let exp3 = expression arity exp3 in
- make_exp expr tgt arity (Ast0.CondExpr(exp1,why,exp2,colon,exp3))
- | Ast0.Postfix(exp,op) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let exp = expression arity exp in
- let op = mcode op in
- make_exp expr tgt arity (Ast0.Postfix(exp,op))
- | Ast0.Infix(exp,op) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let exp = expression arity exp in
- let op = mcode op in
- make_exp expr tgt arity (Ast0.Infix(exp,op))
- | Ast0.Unary(exp,op) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let exp = expression arity exp in
- let op = mcode op in
- make_exp expr tgt arity (Ast0.Unary(exp,op))
- | Ast0.Binary(left,op,right) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let left = expression arity left in
- let op = mcode op in
- let right = expression arity right in
- make_exp expr tgt arity (Ast0.Binary(left,op,right))
- | Ast0.Nested(left,op,right) -> failwith "nested in arity not possible"
- | Ast0.Paren(lp,exp,rp) ->
- let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- make_exp expr tgt arity (Ast0.Paren(lp,exp,rp))
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- let arity = exp_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
- let exp1 = expression arity exp1 in
- let lb = mcode lb in
- let exp2 = expression arity exp2 in
- let rb = mcode rb in
- make_exp expr tgt arity (Ast0.ArrayAccess(exp1,lb,exp2,rb))
- | Ast0.RecordAccess(exp,pt,field) ->
- let arity = exp_same (mcode2line pt) [mcode2arity pt] in
- let exp = expression arity exp in
- let pt = mcode pt in
- let field = ident false arity field in
- make_exp expr tgt arity (Ast0.RecordAccess(exp,pt,field))
- | Ast0.RecordPtAccess(exp,ar,field) ->
- let arity = exp_same (mcode2line ar) [mcode2arity ar] in
- let exp = expression arity exp in
- let ar = mcode ar in
- let field = ident false arity field in
- make_exp expr tgt arity (Ast0.RecordPtAccess(exp,ar,field))
- | Ast0.Cast(lp,ty,rp,exp) ->
- let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let lp = mcode lp in
- let ty = typeC arity ty in
- let rp = mcode rp in
- let exp = expression arity exp in
- make_exp expr tgt arity (Ast0.Cast(lp,ty,rp,exp))
- | Ast0.SizeOfExpr(szf,exp) ->
- let arity = exp_same (mcode2line szf) [mcode2arity szf] in
- let szf = mcode szf in
- let exp = expression arity exp in
- make_exp expr tgt arity (Ast0.SizeOfExpr(szf,exp))
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- let arity =
- exp_same (mcode2line szf) (List.map mcode2arity [szf;lp;rp]) in
- let szf = mcode szf in
- let lp = mcode lp in
- let ty = typeC arity ty in
- let rp = mcode rp in
- make_exp expr tgt arity (Ast0.SizeOfType(szf,lp,ty,rp))
- | Ast0.TypeExp(ty) -> Ast0.rewrap expr (Ast0.TypeExp(typeC tgt ty))
- | Ast0.MetaErr(name,constraints,pure) ->
- let arity = exp_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_exp expr tgt arity (Ast0.MetaErr(name,constraints,pure))
- | Ast0.MetaExpr(name,constraints,ty,form,pure) ->
- let arity = exp_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_exp expr tgt arity (Ast0.MetaExpr(name,constraints,ty,form,pure))
- | Ast0.MetaExprList(name,lenname,pure) ->
- let arity = exp_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_exp expr tgt arity (Ast0.MetaExprList(name,lenname,pure))
- | Ast0.EComma(cm) ->
- let arity = exp_same (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_exp expr tgt arity (Ast0.EComma(cm))
- | Ast0.DisjExpr(starter,exps,mids,ender) ->
- let exps = List.map (top_expression opt_allowed tgt) exps in
- (match List.rev exps with
- _::xs ->
- if anyopt xs (function Ast0.OptExp(_) -> true | _ -> false)
- then fail expr "opt only allowed in the last disjunct"
- | _ -> ());
- Ast0.rewrap expr (Ast0.DisjExpr(starter,exps,mids,ender))
- | Ast0.NestExpr(starter,exp_dots,ender,whencode,multi) ->
- let res =
- Ast0.NestExpr(starter,
- dots (top_expression true Ast0.NONE) exp_dots,
- ender,whencode,multi) in
- Ast0.rewrap expr res
- | Ast0.Edots(dots,whencode) ->
- let arity = exp_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (expression Ast0.NONE) whencode in
- make_exp expr tgt arity (Ast0.Edots(dots,whencode))
- | Ast0.Ecircles(dots,whencode) ->
- let arity = exp_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (expression Ast0.NONE) whencode in
- make_exp expr tgt arity (Ast0.Ecircles(dots,whencode))
- | Ast0.Estars(dots,whencode) ->
- let arity = exp_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (expression Ast0.NONE) whencode in
- make_exp expr tgt arity (Ast0.Estars(dots,whencode))
- | Ast0.OptExp(_) | Ast0.UniqueExp(_) ->
- failwith "unexpected code"
-
-and expression tgt exp = top_expression false tgt exp
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and make_typeC =
- make_opt_unique
- (function x -> Ast0.OptType x)
- (function x -> Ast0.UniqueType x)
-
-and top_typeC tgt opt_allowed typ =
- match Ast0.unwrap typ with
- Ast0.ConstVol(cv,ty) ->
- let arity = all_same opt_allowed tgt (mcode2line cv)
- [mcode2arity cv] in
- let cv = mcode cv in
- let ty = typeC arity ty in
- make_typeC typ tgt arity (Ast0.ConstVol(cv,ty))
- | Ast0.BaseType(ty,strings) ->
- let arity =
- all_same opt_allowed tgt (mcode2line (List.hd strings))
- (List.map mcode2arity strings) in
- let strings = List.map mcode strings in
- make_typeC typ tgt arity (Ast0.BaseType(ty,strings))
- | Ast0.Signed(sign,ty) ->
- let arity =
- all_same opt_allowed tgt (mcode2line sign) [mcode2arity sign] in
- let sign = mcode sign in
- let ty = get_option (typeC arity) ty in
- make_typeC typ tgt arity (Ast0.Signed(sign,ty))
- | Ast0.Pointer(ty,star) ->
- let arity =
- all_same opt_allowed tgt (mcode2line star) [mcode2arity star] in
- let ty = typeC arity ty in
- let star = mcode star in
- make_typeC typ tgt arity (Ast0.Pointer(ty,star))
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lp1)
- (List.map mcode2arity [lp1;star;rp1;lp2;rp2]) in
- let ty = typeC arity ty in
- let params = parameter_list tgt params in
- make_typeC typ tgt arity
- (Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2))
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lp1)
- (List.map mcode2arity [lp1;rp1]) in
- let ty = get_option (typeC arity) ty in
- let params = parameter_list tgt params in
- make_typeC typ tgt arity (Ast0.FunctionType(ty,lp1,params,rp1))
- | Ast0.Array(ty,lb,size,rb) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lb)
- [mcode2arity lb;mcode2arity rb] in
- let ty = typeC arity ty in
- let lb = mcode lb in
- let size = get_option (expression arity) size in
- let rb = mcode rb in
- make_typeC typ tgt arity (Ast0.Array(ty,lb,size,rb))
- | Ast0.EnumName(kind,name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line kind) [mcode2arity kind] in
- let kind = mcode kind in
- let name = ident false arity name in
- make_typeC typ tgt arity (Ast0.EnumName(kind,name))
- | Ast0.StructUnionName(kind,name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line kind)
- [mcode2arity kind] in
- let kind = mcode kind in
- let name = get_option (ident false arity) name in
- make_typeC typ tgt arity (Ast0.StructUnionName(kind,name))
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lb)
- (List.map mcode2arity [lb;rb]) in
- let ty = typeC arity ty in
- let lb = mcode lb in
- let decls = dots (declaration tgt) decls in
- let rb = mcode rb in
- make_typeC typ tgt arity (Ast0.StructUnionDef(ty,lb,decls,rb))
- | Ast0.TypeName(name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_typeC typ tgt arity (Ast0.TypeName(name))
- | Ast0.MetaType(name,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_typeC typ tgt arity (Ast0.MetaType(name,pure))
- | Ast0.DisjType(starter,types,mids,ender) ->
- let types = List.map (typeC tgt) types in
- (match List.rev types with
- _::xs ->
- if anyopt xs (function Ast0.OptType(_) -> true | _ -> false)
- then fail typ "opt only allowed in the last disjunct"
- | _ -> ());
- let res = Ast0.DisjType(starter,types,mids,ender) in
- Ast0.rewrap typ res
- | Ast0.OptType(_) | Ast0.UniqueType(_) ->
- failwith "unexpected code"
-
-and typeC tgt ty = top_typeC tgt false ty
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and make_decl =
- make_opt_unique
- (function x -> Ast0.OptDecl x)
- (function x -> Ast0.UniqueDecl x)
-
-and declaration tgt decl =
- match Ast0.unwrap decl with
- Ast0.Init(stg,ty,id,eq,exp,sem) ->
- let arity =
- all_same true tgt (mcode2line eq)
- ((match stg with None -> [] | Some x -> [mcode2arity x]) @
- (List.map mcode2arity [eq;sem])) in
- let stg = get_option mcode stg in
- let ty = typeC arity ty in
- let id = ident false arity id in
- let eq = mcode eq in
- let exp = initialiser arity exp in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.Init(stg,ty,id,eq,exp,sem))
- | Ast0.UnInit(stg,ty,id,sem) ->
- let arity =
- all_same true tgt (mcode2line sem)
- ((match stg with None -> [] | Some x -> [mcode2arity x]) @
- [mcode2arity sem]) in
- let stg = get_option mcode stg in
- let ty = typeC arity ty in
- let id = ident false arity id in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.UnInit(stg,ty,id,sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- let arity =
- all_same true tgt (mcode2line lp) (List.map mcode2arity [lp;rp;sem]) in
- let name = ident false arity name in
- let lp = mcode lp in
- let args = dots (expression arity) args in
- let rp = mcode rp in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.MacroDecl(name,lp,args,rp,sem))
- | Ast0.TyDecl(ty,sem) ->
- let arity =
- all_same true tgt (mcode2line sem) [mcode2arity sem] in
- let ty = typeC arity ty in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.TyDecl(ty,sem))
- | Ast0.Typedef(stg,ty,id,sem) ->
- let arity =
- all_same true tgt (mcode2line sem)
- [mcode2arity stg;mcode2arity sem] in
- let stg = mcode stg in
- let ty = typeC arity ty in
- let id = typeC arity id in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.Typedef(stg,ty,id,sem))
- | Ast0.DisjDecl(starter,decls,mids,ender) ->
- let decls = List.map (declaration tgt) decls in
- (match List.rev decls with
- _::xs ->
- if anyopt xs (function Ast0.OptDecl(_) -> true | _ -> false)
- then fail decl "opt only allowed in the last disjunct"
- | _ -> ());
- let res = Ast0.DisjDecl(starter,decls,mids,ender) in
- Ast0.rewrap decl res
- | Ast0.Ddots(dots,whencode) ->
- let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (declaration Ast0.NONE) whencode in
- make_decl decl tgt arity (Ast0.Ddots(dots,whencode))
- | Ast0.OptDecl(_) | Ast0.UniqueDecl(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Initializer *)
-
-and make_init =
- make_opt_unique
- (function x -> Ast0.OptIni x)
- (function x -> Ast0.UniqueIni x)
-
-and initialiser tgt i =
- let init_same = all_same true tgt in
- match Ast0.unwrap i with
- Ast0.InitExpr(exp) ->
- Ast0.rewrap i (Ast0.InitExpr(expression tgt exp))
- | Ast0.InitList(lb,initlist,rb) ->
- let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
- let lb = mcode lb in
- let initlist = dots (initialiser arity) initlist in
- let rb = mcode rb in
- make_init i tgt arity (Ast0.InitList(lb,initlist,rb))
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- let arity =
- init_same (mcode2line dot) [mcode2arity dot; mcode2arity eq] in
- let dot = mcode dot in
- let name = ident true arity name in
- let eq = mcode eq in
- let ini = initialiser arity ini in
- make_init i tgt arity (Ast0.InitGccDotName(dot,name,eq,ini))
- | Ast0.InitGccName(name,eq,ini) ->
- let arity = init_same (mcode2line eq) [mcode2arity eq] in
- let name = ident true arity name in
- let eq = mcode eq in
- let ini = initialiser arity ini in
- make_init i tgt arity (Ast0.InitGccName(name,eq,ini))
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- let arity =
- init_same (mcode2line lb)
- [mcode2arity lb; mcode2arity rb; mcode2arity eq] in
- let lb = mcode lb in
- let exp = expression arity exp in
- let rb = mcode rb in
- let eq = mcode eq in
- let ini = initialiser arity ini in
- make_init i tgt arity (Ast0.InitGccIndex(lb,exp,rb,eq,ini))
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- let arity =
- init_same (mcode2line lb)
- [mcode2arity lb; mcode2arity dots; mcode2arity rb; mcode2arity eq] in
- let lb = mcode lb in
- let exp1 = expression arity exp1 in
- let dots = mcode dots in
- let exp2 = expression arity exp2 in
- let rb = mcode rb in
- let eq = mcode eq in
- let ini = initialiser arity ini in
- make_init i tgt arity
- (Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini))
- | Ast0.IComma(cm) ->
- let arity = init_same (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_init i tgt arity (Ast0.IComma(cm))
- | Ast0.Idots(dots,whencode) ->
- let arity = init_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (initialiser Ast0.NONE) whencode in
- make_init i tgt arity (Ast0.Idots(dots,whencode))
- | Ast0.OptIni(_) | Ast0.UniqueIni(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and make_param =
- make_opt_unique
- (function x -> Ast0.OptParam x)
- (function x -> Ast0.UniqueParam x)
-
-and parameterTypeDef tgt param =
- let param_same = all_same true tgt in
- match Ast0.unwrap param with
- Ast0.VoidParam(ty) -> Ast0.rewrap param (Ast0.VoidParam(typeC tgt ty))
- | Ast0.Param(ty,Some id) ->
- let ty = top_typeC tgt true ty in
- let id = ident true tgt id in
- Ast0.rewrap param
- (match (Ast0.unwrap ty,Ast0.unwrap id) with
- (Ast0.OptType(ty),Ast0.OptIdent(id)) ->
- Ast0.OptParam(Ast0.rewrap param (Ast0.Param(ty,Some id)))
- | (Ast0.UniqueType(ty),Ast0.UniqueIdent(id)) ->
- Ast0.UniqueParam(Ast0.rewrap param (Ast0.Param(ty,Some id)))
- | (Ast0.OptType(ty),_) ->
- fail param "arity mismatch in param declaration"
- | (_,Ast0.OptIdent(id)) ->
- fail param "arity mismatch in param declaration"
- | _ -> Ast0.Param(ty,Some id))
- | Ast0.Param(ty,None) ->
- let ty = top_typeC tgt true ty in
- Ast0.rewrap param
- (match Ast0.unwrap ty with
- Ast0.OptType(ty) ->
- Ast0.OptParam(Ast0.rewrap param (Ast0.Param(ty,None)))
- | Ast0.UniqueType(ty) ->
- Ast0.UniqueParam(Ast0.rewrap param (Ast0.Param(ty,None)))
- | _ -> Ast0.Param(ty,None))
- | Ast0.MetaParam(name,pure) ->
- let arity = param_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_param param tgt arity (Ast0.MetaParam(name,pure))
- | Ast0.MetaParamList(name,lenname,pure) ->
- let arity = param_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_param param tgt arity (Ast0.MetaParamList(name,lenname,pure))
- | Ast0.PComma(cm) ->
- let arity = param_same (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_param param tgt arity (Ast0.PComma(cm))
- | Ast0.Pdots(dots) ->
- let arity = param_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- make_param param tgt arity (Ast0.Pdots(dots))
- | Ast0.Pcircles(dots) ->
- let arity = param_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- make_param param tgt arity (Ast0.Pcircles(dots))
- | Ast0.OptParam(_) | Ast0.UniqueParam(_) ->
- failwith "unexpected code"
-
-and parameter_list tgt = dots (parameterTypeDef tgt)
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and make_rule_elem x =
- make_opt_unique
- (function x -> Ast0.OptStm x)
- (function x -> Ast0.UniqueStm x)
- x
-
-and statement tgt stm =
- let stm_same = all_same true tgt in
- match Ast0.unwrap stm with
- Ast0.Decl(bef,decl) ->
- let new_decl = declaration tgt decl in
- Ast0.rewrap stm
- (match Ast0.unwrap new_decl with
- Ast0.OptDecl(decl) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.Decl(bef,decl)))
- | Ast0.UniqueDecl(decl) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.Decl(bef,decl)))
- | _ -> Ast0.Decl(bef,new_decl))
- | Ast0.Seq(lbrace,body,rbrace) ->
- let arity =
- stm_same (mcode2line lbrace)
- [mcode2arity lbrace; mcode2arity rbrace] in
- let lbrace = mcode lbrace in
- let body = dots (statement arity) body in
- let rbrace = mcode rbrace in
- make_rule_elem stm tgt arity (Ast0.Seq(lbrace,body,rbrace))
- | Ast0.ExprStatement(exp,sem) ->
- let arity = stm_same (mcode2line sem) [mcode2arity sem] in
- let exp = expression arity exp in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.ExprStatement(exp,sem))
- | Ast0.IfThen(iff,lp,exp,rp,branch,aft) ->
- let arity =
- stm_same (mcode2line iff) (List.map mcode2arity [iff;lp;rp]) in
- let iff = mcode iff in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let branch = statement arity branch in
- make_rule_elem stm tgt arity (Ast0.IfThen(iff,lp,exp,rp,branch,aft))
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft) ->
- let arity =
- stm_same (mcode2line iff) (List.map mcode2arity [iff;lp;rp;els]) in
- let iff = mcode iff in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let branch1 = statement arity branch1 in
- let els = mcode els in
- let branch2 = statement arity branch2 in
- make_rule_elem stm tgt arity
- (Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft))
- | Ast0.While(wh,lp,exp,rp,body,aft) ->
- let arity =
- stm_same (mcode2line wh)
- (List.map mcode2arity [wh;lp;rp]) in
- let wh = mcode wh in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let body = statement arity body in
- make_rule_elem stm tgt arity (Ast0.While(wh,lp,exp,rp,body,aft))
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- let arity =
- stm_same (mcode2line wh) (List.map mcode2arity [d;wh;lp;rp;sem]) in
- let d = mcode d in
- let body = statement arity body in
- let wh = mcode wh in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Do(d,body,wh,lp,exp,rp,sem))
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft) ->
- let arity =
- stm_same (mcode2line fr) (List.map mcode2arity [fr;lp;sem1;sem2;rp]) in
- let fr = mcode fr in
- let lp = mcode lp in
- let exp1 = get_option (expression arity) exp1 in
- let sem1 = mcode sem1 in
- let exp2 = get_option (expression arity) exp2 in
- let sem2= mcode sem2 in
- let exp3 = get_option (expression arity) exp3 in
- let rp = mcode rp in
- let body = statement arity body in
- make_rule_elem stm tgt arity
- (Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft))
- | Ast0.Iterator(nm,lp,args,rp,body,aft) ->
- let arity = stm_same (mcode2line lp) (List.map mcode2arity [lp;rp]) in
- let nm = ident false arity nm in
- let lp = mcode lp in
- let args = dots (expression arity) args in
- let rp = mcode rp in
- let body = statement arity body in
- make_rule_elem stm tgt arity (Ast0.Iterator(nm,lp,args,rp,body,aft))
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- let arity =
- stm_same (mcode2line switch)
- (List.map mcode2arity [switch;lp;rp;lb;rb]) in
- let switch = mcode switch in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let lb = mcode lb in
- let cases = dots (case_line arity) cases in
- let rb = mcode rb in
- make_rule_elem stm tgt arity
- (Ast0.Switch(switch,lp,exp,rp,lb,cases,rb))
- | Ast0.Break(br,sem) ->
- let arity = stm_same (mcode2line br) (List.map mcode2arity [br;sem]) in
- let br = mcode br in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Break(br,sem))
- | Ast0.Continue(cont,sem) ->
- let arity =
- stm_same (mcode2line cont) (List.map mcode2arity [cont;sem]) in
- let cont = mcode cont in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Continue(cont,sem))
- | Ast0.Label(l,dd) ->
- let arity = mcode2arity dd in
- let l = ident false tgt l in
- let dd = mcode dd in
- make_rule_elem stm tgt arity (Ast0.Label(l,dd))
- | Ast0.Goto(goto,l,sem) ->
- let arity =
- stm_same (mcode2line goto) (List.map mcode2arity [goto;sem]) in
- let goto = mcode goto in
- let l = ident false tgt l in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Goto(goto,l,sem))
- | Ast0.Return(ret,sem) ->
- let arity = stm_same (mcode2line ret) (List.map mcode2arity [ret;sem]) in
- let ret = mcode ret in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Return(ret,sem))
- | Ast0.ReturnExpr(ret,exp,sem) ->
- let arity = stm_same (mcode2line ret) (List.map mcode2arity [ret;sem]) in
- let ret = mcode ret in
- let exp = expression arity exp in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.ReturnExpr(ret,exp,sem))
- | Ast0.MetaStmt(name,pure) ->
- let arity = stm_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_rule_elem stm tgt arity (Ast0.MetaStmt(name,pure))
- | Ast0.MetaStmtList(name,pure) ->
- let arity = stm_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_rule_elem stm tgt arity (Ast0.MetaStmtList(name,pure))
- | Ast0.Exp(exp) ->
- let new_exp = top_expression true tgt exp in
- Ast0.rewrap stm
- (match Ast0.unwrap new_exp with
- Ast0.OptExp(exp) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.Exp(exp)))
- | Ast0.UniqueExp(exp) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.Exp(exp)))
- | _ -> Ast0.Exp(new_exp))
- | Ast0.TopExp(exp) ->
- let new_exp = top_expression true tgt exp in
- Ast0.rewrap stm
- (match Ast0.unwrap new_exp with
- Ast0.OptExp(exp) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.TopExp(exp)))
- | Ast0.UniqueExp(exp) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.TopExp(exp)))
- | _ -> Ast0.TopExp(new_exp))
- | Ast0.Ty(ty) ->
- let new_ty = typeC tgt ty in (* opt makes no sense alone at top level *)
- Ast0.rewrap stm
- (match Ast0.unwrap new_ty with
- Ast0.OptType(ty) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.Ty(ty)))
- | Ast0.UniqueType(ty) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.Ty(ty)))
- | _ -> Ast0.Ty(new_ty))
- | Ast0.TopInit(init) ->
- let new_init = initialiser tgt init in
- Ast0.rewrap stm
- (match Ast0.unwrap new_init with
- Ast0.OptIni(init) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.TopInit(init)))
- | Ast0.UniqueIni(init) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.TopInit(init)))
- | _ -> Ast0.TopInit(new_init))
- | Ast0.Disj(starter,rule_elem_dots_list,mids,ender) ->
- let stms =
- List.map (function x -> concat_dots (statement tgt) x)
- rule_elem_dots_list in
- let (found_opt,unopt) =
- List.fold_left
- (function (found_opt,lines) ->
- function x ->
- let rebuild l =
- (* previously just checked the last thing in the list,
- but everything should be optional for the whole thing to
- be optional *)
- let is_opt x =
- match Ast0.unwrap x with
- Ast0.OptStm(x) -> true
- | _ -> false in
- let unopt x =
- match Ast0.unwrap x with
- Ast0.OptStm(x) -> x
- | _ -> x in
- if List.for_all is_opt l
- then (true,List.map unopt l)
- else (false, l) in
- let (l,k) =
- match Ast0.unwrap x with
- Ast0.DOTS(l) ->
- (l,function l -> Ast0.rewrap x (Ast0.DOTS l))
- | Ast0.CIRCLES(l) ->
- (l,function l -> Ast0.rewrap x (Ast0.CIRCLES l))
- | Ast0.STARS(l) ->
- (l,function l -> Ast0.rewrap x (Ast0.STARS l)) in
- let (found_opt,l) = rebuild l in
- (found_opt,(k l)::lines))
- (false,[]) stms in
- let unopt = List.rev unopt in
- if found_opt
- then
- make_rule_elem stm tgt Ast0.OPT (Ast0.Disj(starter,unopt,mids,ender))
- else Ast0.rewrap stm (Ast0.Disj(starter,stms,mids,ender))
- | Ast0.Nest(starter,rule_elem_dots,ender,whn,multi) ->
- let new_rule_elem_dots =
- concat_dots (statement Ast0.NONE) rule_elem_dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- Ast0.rewrap stm
- (Ast0.Nest(starter,new_rule_elem_dots,ender,whn,multi))
- | Ast0.Dots(dots,whn) ->
- let arity = stm_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- make_rule_elem stm tgt arity (Ast0.Dots(dots,whn))
- | Ast0.Circles(dots,whn) ->
- let arity = stm_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- make_rule_elem stm tgt arity (Ast0.Circles(dots,whn))
- | Ast0.Stars(dots,whn) ->
- let arity = stm_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- make_rule_elem stm tgt arity (Ast0.Stars(dots,whn))
- | Ast0.FunDecl(bef,fi,name,lp,params,rp,lbrace,body,rbrace) ->
- let arity =
- all_same true tgt (mcode2line lp)
- ((List.map mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi)) in
- let fi = List.map (fninfo arity) fi in
- let name = ident false arity name in
- let lp = mcode lp in
- let params = parameter_list arity params in
- let rp = mcode rp in
- let lbrace = mcode lbrace in
- let body = dots (statement arity) body in
- let rbrace = mcode rbrace in
- make_rule_elem stm tgt arity
- (Ast0.FunDecl(bef,fi,name,lp,params,rp,lbrace,body,rbrace))
- | Ast0.Include(inc,s) ->
- let arity =
- all_same true tgt (mcode2line inc) [mcode2arity inc; mcode2arity s] in
- let inc = mcode inc in
- let s = mcode s in
- make_rule_elem stm tgt arity (Ast0.Include(inc,s))
- | Ast0.Define(def,id,params,body) ->
- let arity = all_same true tgt (mcode2line def) [mcode2arity def] in
- let def = mcode def in
- let id = ident false arity id in
- let params = define_parameters arity params in
- let body = dots (statement arity) body in
- make_rule_elem stm tgt arity (Ast0.Define(def,id,params,body))
- | Ast0.OptStm(_) | Ast0.UniqueStm(_) ->
- failwith "unexpected code"
-
-and define_parameters tgt params =
- match Ast0.unwrap params with
- Ast0.NoParams -> params
- | Ast0.DParams(lp,params,rp) ->
- let arity =
- all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let lp = mcode lp in
- let params = dots (define_param arity) params in
- let rp = mcode rp in
- Ast0.rewrap params (Ast0.DParams(lp,params,rp))
-
-and make_define_param x =
- make_opt_unique
- (function x -> Ast0.OptDParam x)
- (function x -> Ast0.UniqueDParam x)
- x
-
-and define_param tgt param =
- match Ast0.unwrap param with
- Ast0.DParam(id) ->
- let new_id = ident true tgt id in
- Ast0.rewrap param
- (match Ast0.unwrap new_id with
- Ast0.OptIdent(id) ->
- Ast0.OptDParam(Ast0.rewrap param (Ast0.DParam(id)))
- | Ast0.UniqueIdent(decl) ->
- Ast0.UniqueDParam(Ast0.rewrap param (Ast0.DParam(id)))
- | _ -> Ast0.DParam(new_id))
- | Ast0.DPComma(cm) ->
- let arity =
- all_same true tgt (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_define_param param tgt arity (Ast0.DPComma(cm))
- | Ast0.DPdots(dots) ->
- let arity =
- all_same true tgt (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- make_define_param param tgt arity (Ast0.DPdots(dots))
- | Ast0.DPcircles(circles) ->
- let arity =
- all_same true tgt (mcode2line circles) [mcode2arity circles] in
- let circles = mcode circles in
- make_define_param param tgt arity (Ast0.DPcircles(circles))
- | Ast0.OptDParam(dp) | Ast0.UniqueDParam(dp) ->
- failwith "unexpected code"
-
-and fninfo arity = function
- Ast0.FStorage(stg) -> Ast0.FStorage(mcode stg)
- | Ast0.FType(ty) -> Ast0.FType(typeC arity ty)
- | Ast0.FInline(inline) -> Ast0.FInline(mcode inline)
- | Ast0.FAttr(attr) -> Ast0.FAttr(mcode attr)
-
-and fninfo2arity fninfo =
- List.concat
- (List.map
- (function
- Ast0.FStorage(stg) -> [mcode2arity stg]
- | Ast0.FType(ty) -> []
- | Ast0.FInline(inline) -> [mcode2arity inline]
- | Ast0.FAttr(attr) -> [mcode2arity attr])
- fninfo)
-
-and whencode notfn alwaysfn expression = function
- Ast0.WhenNot a -> Ast0.WhenNot (notfn a)
- | Ast0.WhenAlways a -> Ast0.WhenAlways (alwaysfn a)
- | Ast0.WhenModifier(x) -> Ast0.WhenModifier(x)
- | Ast0.WhenNotTrue a -> Ast0.WhenNotTrue (expression a)
- | Ast0.WhenNotFalse a -> Ast0.WhenNotFalse (expression a)
-
-and make_case_line =
- make_opt_unique
- (function x -> Ast0.OptCase x)
- (function x -> failwith "unique not allowed for case_line")
-
-and case_line tgt c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- let arity =
- all_same true tgt (mcode2line def)
- [mcode2arity def; mcode2arity colon] in
- let def = mcode def in
- let colon = mcode colon in
- let code = dots (statement arity) code in
- make_case_line c tgt arity (Ast0.Default(def,colon,code))
- | Ast0.Case(case,exp,colon,code) ->
- let arity =
- all_same true tgt (mcode2line case)
- [mcode2arity case; mcode2arity colon] in
- let case = mcode case in
- let exp = expression arity exp in
- let colon = mcode colon in
- let code = dots (statement arity) code in
- make_case_line c tgt arity (Ast0.Case(case,exp,colon,code))
- | Ast0.OptCase(_) -> failwith "unexpected OptCase"
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-(* Haven't thought much about arity here... *)
-
-let top_level tgt t =
- Ast0.rewrap t
- (match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- if mcode2arity old_file = Ast0.NONE && mcode2arity new_file = Ast0.NONE
- then Ast0.FILEINFO(mcode old_file,mcode new_file)
- else fail t "unexpected arity for file info"
- | Ast0.DECL(stmt) ->
- Ast0.DECL(statement tgt stmt)
- | Ast0.CODE(rule_elem_dots) ->
- Ast0.CODE(concat_dots (statement tgt) rule_elem_dots)
- | Ast0.ERRORWORDS(exps) ->
- Ast0.ERRORWORDS(List.map (top_expression false Ast0.NONE) exps)
- | Ast0.OTHER(_) -> fail t "eliminated by top_level")
-
-let rule tgt = List.map (top_level tgt)
-
-(* --------------------------------------------------------------------- *)
-(* Entry points *)
-
-let minus_arity code =
- rule Ast0.NONE code
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Arities matter for the minus slice, but not for the plus slice. *)
-
-(* ? only allowed on rule_elems, and on subterms if the context is ? also. *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-
-let warning s = Printf.printf "warning: %s\n" s
-
-let fail w str =
- failwith
- (Printf.sprintf "cocci line %d: %s" ((Ast0.get_info w).Ast0.line_start)
- str)
-
-let make_opt_unique optfn uniquefn info tgt arity term =
- let term = Ast0.rewrap info term in
- if tgt = arity
- then term
- else (* tgt must be NONE *)
- match arity with
- Ast0.OPT -> Ast0.copywrap info (optfn term)
- | Ast0.UNIQUE -> Ast0.copywrap info (uniquefn term)
- | Ast0.NONE -> failwith "tgt must be NONE"
-
-let all_same opt_allowed tgt line arities =
- let tgt =
- match tgt with
- Ast0.NONE ->
- (match List.hd arities with
- Ast0.OPT when not opt_allowed ->
- failwith "opt only allowed for the elements of a statement list"
- | x -> x)
- | _ -> tgt in
- if not(List.for_all (function x -> x = tgt) arities)
- then warning (Printf.sprintf "incompatible arity found on line %d" line);
- tgt
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-let anyopt l fn = List.exists (function w -> fn(Ast0.unwrap w)) l
-
-let allopt l fn =
- let rec loop = function
- [] -> []
- | x::xs ->
- match fn (Ast0.unwrap x) with
- Some x -> x :: (loop xs)
- | None -> [] in
- let res = loop l in
- if List.length res = List.length l then Some res else None
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Mcode *)
-
-let mcode2line (_,_,info,_,_) = info.Ast0.line_start
-let mcode2arity (_,arity,_,_,_) = arity
-
-let mcode x = x (* nothing to do ... *)
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots fn d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(x) -> Ast0.DOTS(List.map fn x)
- | Ast0.CIRCLES(x) -> Ast0.CIRCLES(List.map fn x)
- | Ast0.STARS(x) -> Ast0.STARS(List.map fn x))
-
-let only_dots l =
- not
- (List.exists
- (function x ->
- match Ast0.unwrap x with
- Ast0.Circles(_,_) | Ast0.Stars(_,_) -> true
- | _ -> false)
- l)
-
-let only_circles l =
- not (List.exists
- (function x ->
- match Ast0.unwrap x with
- Ast0.Dots(_,_) | Ast0.Stars(_,_) -> true
- | _ -> false)
- l)
-
-let only_stars l =
- not (List.exists
- (function x ->
- match Ast0.unwrap x with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) -> true
- | _ -> false)
- l)
-
-let concat_dots fn d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(x) ->
- let l = List.map fn x in
- if only_dots l
- then Ast0.DOTS(l)
- else fail d "inconsistent dots usage"
- | Ast0.CIRCLES(x) ->
- let l = List.map fn x in
- if only_circles l
- then Ast0.CIRCLES(l)
- else fail d "inconsistent dots usage"
- | Ast0.STARS(x) ->
- let l = List.map fn x in
- if only_stars l
- then Ast0.STARS(l)
- else fail d "inconsistent dots usage")
-
-let flat_concat_dots fn d =
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> List.map fn x
- | Ast0.CIRCLES(x) -> List.map fn x
- | Ast0.STARS(x) -> List.map fn x
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let make_id =
- make_opt_unique
- (function x -> Ast0.OptIdent x)
- (function x -> Ast0.UniqueIdent x)
-
-let ident opt_allowed tgt i =
- match Ast0.unwrap i with
- Ast0.Id(name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.Id(name))
- | Ast0.MetaId(name,constraints,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.MetaId(name,constraints,pure))
- | Ast0.MetaFunc(name,constraints,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.MetaFunc(name,constraints,pure))
- | Ast0.MetaLocalFunc(name,constraints,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name)
- [mcode2arity name] in
- let name = mcode name in
- make_id i tgt arity (Ast0.MetaLocalFunc(name,constraints,pure))
- | Ast0.OptIdent(_) | Ast0.UniqueIdent(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let make_exp =
- make_opt_unique
- (function x -> Ast0.OptExp x)
- (function x -> Ast0.UniqueExp x)
-
-let rec top_expression opt_allowed tgt expr =
- let exp_same = all_same opt_allowed tgt in
- match Ast0.unwrap expr with
- Ast0.Ident(id) ->
- let new_id = ident opt_allowed tgt id in
- Ast0.rewrap expr
- (match Ast0.unwrap new_id with
- Ast0.OptIdent(id) ->
- Ast0.OptExp(Ast0.rewrap expr (Ast0.Ident(id)))
- | Ast0.UniqueIdent(id) ->
- Ast0.UniqueExp(Ast0.rewrap expr (Ast0.Ident(id)))
- | _ -> Ast0.Ident(new_id))
- | Ast0.Constant(const) ->
- let arity = exp_same (mcode2line const) [mcode2arity const] in
- let const = mcode const in
- make_exp expr tgt arity (Ast0.Constant(const))
- | Ast0.FunCall(fn,lp,args,rp) ->
- let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let fn = expression arity fn in
- let lp = mcode lp in
- let args = dots (expression arity) args in
- let rp = mcode rp in
- make_exp expr tgt arity (Ast0.FunCall(fn,lp,args,rp))
- | Ast0.Assignment(left,op,right,simple) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let left = expression arity left in
- let op = mcode op in
- let right = expression arity right in
- make_exp expr tgt arity (Ast0.Assignment(left,op,right,simple))
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- let arity =
- exp_same (mcode2line why) [mcode2arity why; mcode2arity colon] in
- let exp1 = expression arity exp1 in
- let why = mcode why in
- let exp2 = get_option (expression arity) exp2 in
- let colon = mcode colon in
- let exp3 = expression arity exp3 in
- make_exp expr tgt arity (Ast0.CondExpr(exp1,why,exp2,colon,exp3))
- | Ast0.Postfix(exp,op) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let exp = expression arity exp in
- let op = mcode op in
- make_exp expr tgt arity (Ast0.Postfix(exp,op))
- | Ast0.Infix(exp,op) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let exp = expression arity exp in
- let op = mcode op in
- make_exp expr tgt arity (Ast0.Infix(exp,op))
- | Ast0.Unary(exp,op) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let exp = expression arity exp in
- let op = mcode op in
- make_exp expr tgt arity (Ast0.Unary(exp,op))
- | Ast0.Binary(left,op,right) ->
- let arity = exp_same (mcode2line op) [mcode2arity op] in
- let left = expression arity left in
- let op = mcode op in
- let right = expression arity right in
- make_exp expr tgt arity (Ast0.Binary(left,op,right))
- | Ast0.Nested(left,op,right) -> failwith "nested in arity not possible"
- | Ast0.Paren(lp,exp,rp) ->
- let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- make_exp expr tgt arity (Ast0.Paren(lp,exp,rp))
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- let arity = exp_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
- let exp1 = expression arity exp1 in
- let lb = mcode lb in
- let exp2 = expression arity exp2 in
- let rb = mcode rb in
- make_exp expr tgt arity (Ast0.ArrayAccess(exp1,lb,exp2,rb))
- | Ast0.RecordAccess(exp,pt,field) ->
- let arity = exp_same (mcode2line pt) [mcode2arity pt] in
- let exp = expression arity exp in
- let pt = mcode pt in
- let field = ident false arity field in
- make_exp expr tgt arity (Ast0.RecordAccess(exp,pt,field))
- | Ast0.RecordPtAccess(exp,ar,field) ->
- let arity = exp_same (mcode2line ar) [mcode2arity ar] in
- let exp = expression arity exp in
- let ar = mcode ar in
- let field = ident false arity field in
- make_exp expr tgt arity (Ast0.RecordPtAccess(exp,ar,field))
- | Ast0.Cast(lp,ty,rp,exp) ->
- let arity = exp_same (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let lp = mcode lp in
- let ty = typeC arity ty in
- let rp = mcode rp in
- let exp = expression arity exp in
- make_exp expr tgt arity (Ast0.Cast(lp,ty,rp,exp))
- | Ast0.SizeOfExpr(szf,exp) ->
- let arity = exp_same (mcode2line szf) [mcode2arity szf] in
- let szf = mcode szf in
- let exp = expression arity exp in
- make_exp expr tgt arity (Ast0.SizeOfExpr(szf,exp))
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- let arity =
- exp_same (mcode2line szf) (List.map mcode2arity [szf;lp;rp]) in
- let szf = mcode szf in
- let lp = mcode lp in
- let ty = typeC arity ty in
- let rp = mcode rp in
- make_exp expr tgt arity (Ast0.SizeOfType(szf,lp,ty,rp))
- | Ast0.TypeExp(ty) -> Ast0.rewrap expr (Ast0.TypeExp(typeC tgt ty))
- | Ast0.MetaErr(name,constraints,pure) ->
- let arity = exp_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_exp expr tgt arity (Ast0.MetaErr(name,constraints,pure))
- | Ast0.MetaExpr(name,constraints,ty,form,pure) ->
- let arity = exp_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_exp expr tgt arity (Ast0.MetaExpr(name,constraints,ty,form,pure))
- | Ast0.MetaExprList(name,lenname,pure) ->
- let arity = exp_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_exp expr tgt arity (Ast0.MetaExprList(name,lenname,pure))
- | Ast0.EComma(cm) ->
- let arity = exp_same (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_exp expr tgt arity (Ast0.EComma(cm))
- | Ast0.DisjExpr(starter,exps,mids,ender) ->
- let exps = List.map (top_expression opt_allowed tgt) exps in
- (match List.rev exps with
- _::xs ->
- if anyopt xs (function Ast0.OptExp(_) -> true | _ -> false)
- then fail expr "opt only allowed in the last disjunct"
- | _ -> ());
- Ast0.rewrap expr (Ast0.DisjExpr(starter,exps,mids,ender))
- | Ast0.NestExpr(starter,exp_dots,ender,whencode,multi) ->
- let res =
- Ast0.NestExpr(starter,
- dots (top_expression true Ast0.NONE) exp_dots,
- ender,whencode,multi) in
- Ast0.rewrap expr res
- | Ast0.Edots(dots,whencode) ->
- let arity = exp_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (expression Ast0.NONE) whencode in
- make_exp expr tgt arity (Ast0.Edots(dots,whencode))
- | Ast0.Ecircles(dots,whencode) ->
- let arity = exp_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (expression Ast0.NONE) whencode in
- make_exp expr tgt arity (Ast0.Ecircles(dots,whencode))
- | Ast0.Estars(dots,whencode) ->
- let arity = exp_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (expression Ast0.NONE) whencode in
- make_exp expr tgt arity (Ast0.Estars(dots,whencode))
- | Ast0.OptExp(_) | Ast0.UniqueExp(_) ->
- failwith "unexpected code"
-
-and expression tgt exp = top_expression false tgt exp
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and make_typeC =
- make_opt_unique
- (function x -> Ast0.OptType x)
- (function x -> Ast0.UniqueType x)
-
-and top_typeC tgt opt_allowed typ =
- match Ast0.unwrap typ with
- Ast0.ConstVol(cv,ty) ->
- let arity = all_same opt_allowed tgt (mcode2line cv)
- [mcode2arity cv] in
- let cv = mcode cv in
- let ty = typeC arity ty in
- make_typeC typ tgt arity (Ast0.ConstVol(cv,ty))
- | Ast0.BaseType(ty,strings) ->
- let arity =
- all_same opt_allowed tgt (mcode2line (List.hd strings))
- (List.map mcode2arity strings) in
- let strings = List.map mcode strings in
- make_typeC typ tgt arity (Ast0.BaseType(ty,strings))
- | Ast0.Signed(sign,ty) ->
- let arity =
- all_same opt_allowed tgt (mcode2line sign) [mcode2arity sign] in
- let sign = mcode sign in
- let ty = get_option (typeC arity) ty in
- make_typeC typ tgt arity (Ast0.Signed(sign,ty))
- | Ast0.Pointer(ty,star) ->
- let arity =
- all_same opt_allowed tgt (mcode2line star) [mcode2arity star] in
- let ty = typeC arity ty in
- let star = mcode star in
- make_typeC typ tgt arity (Ast0.Pointer(ty,star))
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lp1)
- (List.map mcode2arity [lp1;star;rp1;lp2;rp2]) in
- let ty = typeC arity ty in
- let params = parameter_list tgt params in
- make_typeC typ tgt arity
- (Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2))
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lp1)
- (List.map mcode2arity [lp1;rp1]) in
- let ty = get_option (typeC arity) ty in
- let params = parameter_list tgt params in
- make_typeC typ tgt arity (Ast0.FunctionType(ty,lp1,params,rp1))
- | Ast0.Array(ty,lb,size,rb) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lb)
- [mcode2arity lb;mcode2arity rb] in
- let ty = typeC arity ty in
- let lb = mcode lb in
- let size = get_option (expression arity) size in
- let rb = mcode rb in
- make_typeC typ tgt arity (Ast0.Array(ty,lb,size,rb))
- | Ast0.EnumName(kind,name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line kind) [mcode2arity kind] in
- let kind = mcode kind in
- let name = ident false arity name in
- make_typeC typ tgt arity (Ast0.EnumName(kind,name))
- | Ast0.StructUnionName(kind,name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line kind)
- [mcode2arity kind] in
- let kind = mcode kind in
- let name = get_option (ident false arity) name in
- make_typeC typ tgt arity (Ast0.StructUnionName(kind,name))
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- let arity =
- all_same opt_allowed tgt (mcode2line lb)
- (List.map mcode2arity [lb;rb]) in
- let ty = typeC arity ty in
- let lb = mcode lb in
- let decls = dots (declaration tgt) decls in
- let rb = mcode rb in
- make_typeC typ tgt arity (Ast0.StructUnionDef(ty,lb,decls,rb))
- | Ast0.TypeName(name) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_typeC typ tgt arity (Ast0.TypeName(name))
- | Ast0.MetaType(name,pure) ->
- let arity =
- all_same opt_allowed tgt (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_typeC typ tgt arity (Ast0.MetaType(name,pure))
- | Ast0.DisjType(starter,types,mids,ender) ->
- let types = List.map (typeC tgt) types in
- (match List.rev types with
- _::xs ->
- if anyopt xs (function Ast0.OptType(_) -> true | _ -> false)
- then fail typ "opt only allowed in the last disjunct"
- | _ -> ());
- let res = Ast0.DisjType(starter,types,mids,ender) in
- Ast0.rewrap typ res
- | Ast0.OptType(_) | Ast0.UniqueType(_) ->
- failwith "unexpected code"
-
-and typeC tgt ty = top_typeC tgt false ty
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and make_decl =
- make_opt_unique
- (function x -> Ast0.OptDecl x)
- (function x -> Ast0.UniqueDecl x)
-
-and declaration tgt decl =
- match Ast0.unwrap decl with
- Ast0.Init(stg,ty,id,eq,exp,sem) ->
- let arity =
- all_same true tgt (mcode2line eq)
- ((match stg with None -> [] | Some x -> [mcode2arity x]) @
- (List.map mcode2arity [eq;sem])) in
- let stg = get_option mcode stg in
- let ty = typeC arity ty in
- let id = ident false arity id in
- let eq = mcode eq in
- let exp = initialiser arity exp in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.Init(stg,ty,id,eq,exp,sem))
- | Ast0.UnInit(stg,ty,id,sem) ->
- let arity =
- all_same true tgt (mcode2line sem)
- ((match stg with None -> [] | Some x -> [mcode2arity x]) @
- [mcode2arity sem]) in
- let stg = get_option mcode stg in
- let ty = typeC arity ty in
- let id = ident false arity id in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.UnInit(stg,ty,id,sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- let arity =
- all_same true tgt (mcode2line lp) (List.map mcode2arity [lp;rp;sem]) in
- let name = ident false arity name in
- let lp = mcode lp in
- let args = dots (expression arity) args in
- let rp = mcode rp in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.MacroDecl(name,lp,args,rp,sem))
- | Ast0.TyDecl(ty,sem) ->
- let arity =
- all_same true tgt (mcode2line sem) [mcode2arity sem] in
- let ty = typeC arity ty in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.TyDecl(ty,sem))
- | Ast0.Typedef(stg,ty,id,sem) ->
- let arity =
- all_same true tgt (mcode2line sem)
- [mcode2arity stg;mcode2arity sem] in
- let stg = mcode stg in
- let ty = typeC arity ty in
- let id = typeC arity id in
- let sem = mcode sem in
- make_decl decl tgt arity (Ast0.Typedef(stg,ty,id,sem))
- | Ast0.DisjDecl(starter,decls,mids,ender) ->
- let decls = List.map (declaration tgt) decls in
- (match List.rev decls with
- _::xs ->
- if anyopt xs (function Ast0.OptDecl(_) -> true | _ -> false)
- then fail decl "opt only allowed in the last disjunct"
- | _ -> ());
- let res = Ast0.DisjDecl(starter,decls,mids,ender) in
- Ast0.rewrap decl res
- | Ast0.Ddots(dots,whencode) ->
- let arity = all_same true tgt (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (declaration Ast0.NONE) whencode in
- make_decl decl tgt arity (Ast0.Ddots(dots,whencode))
- | Ast0.OptDecl(_) | Ast0.UniqueDecl(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Initializer *)
-
-and make_init =
- make_opt_unique
- (function x -> Ast0.OptIni x)
- (function x -> Ast0.UniqueIni x)
-
-and initialiser tgt i =
- let init_same = all_same true tgt in
- match Ast0.unwrap i with
- Ast0.MetaInit(name,pure) ->
- let arity = init_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_init i tgt arity (Ast0.MetaInit(name,pure))
- | Ast0.InitExpr(exp) ->
- Ast0.rewrap i (Ast0.InitExpr(expression tgt exp))
- | Ast0.InitList(lb,initlist,rb) ->
- let arity = init_same (mcode2line lb) [mcode2arity lb; mcode2arity rb] in
- let lb = mcode lb in
- let initlist = dots (initialiser arity) initlist in
- let rb = mcode rb in
- make_init i tgt arity (Ast0.InitList(lb,initlist,rb))
- | Ast0.InitGccExt(designators,eq,ini) ->
- let arity = init_same (mcode2line eq) [mcode2arity eq] in
- let designators = List.map (designator arity) designators in
- let eq = mcode eq in
- let ini = initialiser arity ini in
- make_init i tgt arity (Ast0.InitGccExt(designators,eq,ini))
- | Ast0.InitGccName(name,eq,ini) ->
- let arity = init_same (mcode2line eq) [mcode2arity eq] in
- let name = ident true arity name in
- let eq = mcode eq in
- let ini = initialiser arity ini in
- make_init i tgt arity (Ast0.InitGccName(name,eq,ini))
- | Ast0.IComma(cm) ->
- let arity = init_same (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_init i tgt arity (Ast0.IComma(cm))
- | Ast0.Idots(dots,whencode) ->
- let arity = init_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whencode = get_option (initialiser Ast0.NONE) whencode in
- make_init i tgt arity (Ast0.Idots(dots,whencode))
- | Ast0.OptIni(_) | Ast0.UniqueIni(_) ->
- failwith "unexpected code"
-
-and designator tgt d =
- let dsame = all_same false tgt in
- match d with
- Ast0.DesignatorField(dot,id) ->
- let arity = dsame (mcode2line dot) [mcode2arity dot] in
- let dot = mcode dot in
- let id = ident false arity id in
- Ast0.DesignatorField(dot,id)
- | Ast0.DesignatorIndex(lb,exp,rb) ->
- let arity = dsame (mcode2line lb) [mcode2arity lb;mcode2arity rb] in
- let lb = mcode lb in
- let exp = top_expression false arity exp in
- let rb = mcode rb in
- Ast0.DesignatorIndex(lb,exp,rb)
- | Ast0.DesignatorRange(lb,min,dots,max,rb) ->
- let arity =
- dsame (mcode2line lb)
- [mcode2arity lb;mcode2arity dots;mcode2arity rb] in
- let lb = mcode lb in
- let min = top_expression false arity min in
- let dots = mcode dots in
- let max = top_expression false arity max in
- let rb = mcode rb in
- Ast0.DesignatorRange(lb,min,dots,max,rb)
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and make_param =
- make_opt_unique
- (function x -> Ast0.OptParam x)
- (function x -> Ast0.UniqueParam x)
-
-and parameterTypeDef tgt param =
- let param_same = all_same true tgt in
- match Ast0.unwrap param with
- Ast0.VoidParam(ty) -> Ast0.rewrap param (Ast0.VoidParam(typeC tgt ty))
- | Ast0.Param(ty,Some id) ->
- let ty = top_typeC tgt true ty in
- let id = ident true tgt id in
- Ast0.rewrap param
- (match (Ast0.unwrap ty,Ast0.unwrap id) with
- (Ast0.OptType(ty),Ast0.OptIdent(id)) ->
- Ast0.OptParam(Ast0.rewrap param (Ast0.Param(ty,Some id)))
- | (Ast0.UniqueType(ty),Ast0.UniqueIdent(id)) ->
- Ast0.UniqueParam(Ast0.rewrap param (Ast0.Param(ty,Some id)))
- | (Ast0.OptType(ty),_) ->
- fail param "arity mismatch in param declaration"
- | (_,Ast0.OptIdent(id)) ->
- fail param "arity mismatch in param declaration"
- | _ -> Ast0.Param(ty,Some id))
- | Ast0.Param(ty,None) ->
- let ty = top_typeC tgt true ty in
- Ast0.rewrap param
- (match Ast0.unwrap ty with
- Ast0.OptType(ty) ->
- Ast0.OptParam(Ast0.rewrap param (Ast0.Param(ty,None)))
- | Ast0.UniqueType(ty) ->
- Ast0.UniqueParam(Ast0.rewrap param (Ast0.Param(ty,None)))
- | _ -> Ast0.Param(ty,None))
- | Ast0.MetaParam(name,pure) ->
- let arity = param_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_param param tgt arity (Ast0.MetaParam(name,pure))
- | Ast0.MetaParamList(name,lenname,pure) ->
- let arity = param_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_param param tgt arity (Ast0.MetaParamList(name,lenname,pure))
- | Ast0.PComma(cm) ->
- let arity = param_same (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_param param tgt arity (Ast0.PComma(cm))
- | Ast0.Pdots(dots) ->
- let arity = param_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- make_param param tgt arity (Ast0.Pdots(dots))
- | Ast0.Pcircles(dots) ->
- let arity = param_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- make_param param tgt arity (Ast0.Pcircles(dots))
- | Ast0.OptParam(_) | Ast0.UniqueParam(_) ->
- failwith "unexpected code"
-
-and parameter_list tgt = dots (parameterTypeDef tgt)
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and make_rule_elem x =
- make_opt_unique
- (function x -> Ast0.OptStm x)
- (function x -> Ast0.UniqueStm x)
- x
-
-and statement tgt stm =
- let stm_same = all_same true tgt in
- match Ast0.unwrap stm with
- Ast0.Decl(bef,decl) ->
- let new_decl = declaration tgt decl in
- Ast0.rewrap stm
- (match Ast0.unwrap new_decl with
- Ast0.OptDecl(decl) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.Decl(bef,decl)))
- | Ast0.UniqueDecl(decl) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.Decl(bef,decl)))
- | _ -> Ast0.Decl(bef,new_decl))
- | Ast0.Seq(lbrace,body,rbrace) ->
- let arity =
- stm_same (mcode2line lbrace)
- [mcode2arity lbrace; mcode2arity rbrace] in
- let lbrace = mcode lbrace in
- let body = dots (statement arity) body in
- let rbrace = mcode rbrace in
- make_rule_elem stm tgt arity (Ast0.Seq(lbrace,body,rbrace))
- | Ast0.ExprStatement(exp,sem) ->
- let arity = stm_same (mcode2line sem) [mcode2arity sem] in
- let exp = expression arity exp in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.ExprStatement(exp,sem))
- | Ast0.IfThen(iff,lp,exp,rp,branch,aft) ->
- let arity =
- stm_same (mcode2line iff) (List.map mcode2arity [iff;lp;rp]) in
- let iff = mcode iff in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let branch = statement arity branch in
- make_rule_elem stm tgt arity (Ast0.IfThen(iff,lp,exp,rp,branch,aft))
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft) ->
- let arity =
- stm_same (mcode2line iff) (List.map mcode2arity [iff;lp;rp;els]) in
- let iff = mcode iff in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let branch1 = statement arity branch1 in
- let els = mcode els in
- let branch2 = statement arity branch2 in
- make_rule_elem stm tgt arity
- (Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft))
- | Ast0.While(wh,lp,exp,rp,body,aft) ->
- let arity =
- stm_same (mcode2line wh)
- (List.map mcode2arity [wh;lp;rp]) in
- let wh = mcode wh in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let body = statement arity body in
- make_rule_elem stm tgt arity (Ast0.While(wh,lp,exp,rp,body,aft))
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- let arity =
- stm_same (mcode2line wh) (List.map mcode2arity [d;wh;lp;rp;sem]) in
- let d = mcode d in
- let body = statement arity body in
- let wh = mcode wh in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Do(d,body,wh,lp,exp,rp,sem))
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft) ->
- let arity =
- stm_same (mcode2line fr) (List.map mcode2arity [fr;lp;sem1;sem2;rp]) in
- let fr = mcode fr in
- let lp = mcode lp in
- let exp1 = get_option (expression arity) exp1 in
- let sem1 = mcode sem1 in
- let exp2 = get_option (expression arity) exp2 in
- let sem2= mcode sem2 in
- let exp3 = get_option (expression arity) exp3 in
- let rp = mcode rp in
- let body = statement arity body in
- make_rule_elem stm tgt arity
- (Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,aft))
- | Ast0.Iterator(nm,lp,args,rp,body,aft) ->
- let arity = stm_same (mcode2line lp) (List.map mcode2arity [lp;rp]) in
- let nm = ident false arity nm in
- let lp = mcode lp in
- let args = dots (expression arity) args in
- let rp = mcode rp in
- let body = statement arity body in
- make_rule_elem stm tgt arity (Ast0.Iterator(nm,lp,args,rp,body,aft))
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- let arity =
- stm_same (mcode2line switch)
- (List.map mcode2arity [switch;lp;rp;lb;rb]) in
- let switch = mcode switch in
- let lp = mcode lp in
- let exp = expression arity exp in
- let rp = mcode rp in
- let lb = mcode lb in
- let cases = dots (case_line arity) cases in
- let rb = mcode rb in
- make_rule_elem stm tgt arity
- (Ast0.Switch(switch,lp,exp,rp,lb,cases,rb))
- | Ast0.Break(br,sem) ->
- let arity = stm_same (mcode2line br) (List.map mcode2arity [br;sem]) in
- let br = mcode br in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Break(br,sem))
- | Ast0.Continue(cont,sem) ->
- let arity =
- stm_same (mcode2line cont) (List.map mcode2arity [cont;sem]) in
- let cont = mcode cont in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Continue(cont,sem))
- | Ast0.Label(l,dd) ->
- let arity = mcode2arity dd in
- let l = ident false tgt l in
- let dd = mcode dd in
- make_rule_elem stm tgt arity (Ast0.Label(l,dd))
- | Ast0.Goto(goto,l,sem) ->
- let arity =
- stm_same (mcode2line goto) (List.map mcode2arity [goto;sem]) in
- let goto = mcode goto in
- let l = ident false tgt l in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Goto(goto,l,sem))
- | Ast0.Return(ret,sem) ->
- let arity = stm_same (mcode2line ret) (List.map mcode2arity [ret;sem]) in
- let ret = mcode ret in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.Return(ret,sem))
- | Ast0.ReturnExpr(ret,exp,sem) ->
- let arity = stm_same (mcode2line ret) (List.map mcode2arity [ret;sem]) in
- let ret = mcode ret in
- let exp = expression arity exp in
- let sem = mcode sem in
- make_rule_elem stm tgt arity (Ast0.ReturnExpr(ret,exp,sem))
- | Ast0.MetaStmt(name,pure) ->
- let arity = stm_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_rule_elem stm tgt arity (Ast0.MetaStmt(name,pure))
- | Ast0.MetaStmtList(name,pure) ->
- let arity = stm_same (mcode2line name) [mcode2arity name] in
- let name = mcode name in
- make_rule_elem stm tgt arity (Ast0.MetaStmtList(name,pure))
- | Ast0.Exp(exp) ->
- let new_exp = top_expression true tgt exp in
- Ast0.rewrap stm
- (match Ast0.unwrap new_exp with
- Ast0.OptExp(exp) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.Exp(exp)))
- | Ast0.UniqueExp(exp) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.Exp(exp)))
- | _ -> Ast0.Exp(new_exp))
- | Ast0.TopExp(exp) ->
- let new_exp = top_expression true tgt exp in
- Ast0.rewrap stm
- (match Ast0.unwrap new_exp with
- Ast0.OptExp(exp) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.TopExp(exp)))
- | Ast0.UniqueExp(exp) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.TopExp(exp)))
- | _ -> Ast0.TopExp(new_exp))
- | Ast0.Ty(ty) ->
- let new_ty = typeC tgt ty in (* opt makes no sense alone at top level *)
- Ast0.rewrap stm
- (match Ast0.unwrap new_ty with
- Ast0.OptType(ty) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.Ty(ty)))
- | Ast0.UniqueType(ty) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.Ty(ty)))
- | _ -> Ast0.Ty(new_ty))
- | Ast0.TopInit(init) ->
- let new_init = initialiser tgt init in
- Ast0.rewrap stm
- (match Ast0.unwrap new_init with
- Ast0.OptIni(init) ->
- Ast0.OptStm(Ast0.rewrap stm (Ast0.TopInit(init)))
- | Ast0.UniqueIni(init) ->
- Ast0.UniqueStm(Ast0.rewrap stm (Ast0.TopInit(init)))
- | _ -> Ast0.TopInit(new_init))
- | Ast0.Disj(starter,rule_elem_dots_list,mids,ender) ->
- let stms =
- List.map (function x -> concat_dots (statement tgt) x)
- rule_elem_dots_list in
- let (found_opt,unopt) =
- List.fold_left
- (function (found_opt,lines) ->
- function x ->
- let rebuild l =
- (* previously just checked the last thing in the list,
- but everything should be optional for the whole thing to
- be optional *)
- let is_opt x =
- match Ast0.unwrap x with
- Ast0.OptStm(x) -> true
- | _ -> false in
- let unopt x =
- match Ast0.unwrap x with
- Ast0.OptStm(x) -> x
- | _ -> x in
- if List.for_all is_opt l
- then (true,List.map unopt l)
- else (false, l) in
- let (l,k) =
- match Ast0.unwrap x with
- Ast0.DOTS(l) ->
- (l,function l -> Ast0.rewrap x (Ast0.DOTS l))
- | Ast0.CIRCLES(l) ->
- (l,function l -> Ast0.rewrap x (Ast0.CIRCLES l))
- | Ast0.STARS(l) ->
- (l,function l -> Ast0.rewrap x (Ast0.STARS l)) in
- let (found_opt,l) = rebuild l in
- (found_opt,(k l)::lines))
- (false,[]) stms in
- let unopt = List.rev unopt in
- if found_opt
- then
- make_rule_elem stm tgt Ast0.OPT (Ast0.Disj(starter,unopt,mids,ender))
- else Ast0.rewrap stm (Ast0.Disj(starter,stms,mids,ender))
- | Ast0.Nest(starter,rule_elem_dots,ender,whn,multi) ->
- let new_rule_elem_dots =
- concat_dots (statement Ast0.NONE) rule_elem_dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- Ast0.rewrap stm
- (Ast0.Nest(starter,new_rule_elem_dots,ender,whn,multi))
- | Ast0.Dots(dots,whn) ->
- let arity = stm_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- make_rule_elem stm tgt arity (Ast0.Dots(dots,whn))
- | Ast0.Circles(dots,whn) ->
- let arity = stm_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- make_rule_elem stm tgt arity (Ast0.Circles(dots,whn))
- | Ast0.Stars(dots,whn) ->
- let arity = stm_same (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- let whn =
- List.map
- (whencode (concat_dots (statement Ast0.NONE)) (statement Ast0.NONE)
- (expression Ast0.NONE))
- whn in
- make_rule_elem stm tgt arity (Ast0.Stars(dots,whn))
- | Ast0.FunDecl(bef,fi,name,lp,params,rp,lbrace,body,rbrace) ->
- let arity =
- all_same true tgt (mcode2line lp)
- ((List.map mcode2arity [lp;rp;lbrace;rbrace]) @ (fninfo2arity fi)) in
- let fi = List.map (fninfo arity) fi in
- let name = ident false arity name in
- let lp = mcode lp in
- let params = parameter_list arity params in
- let rp = mcode rp in
- let lbrace = mcode lbrace in
- let body = dots (statement arity) body in
- let rbrace = mcode rbrace in
- make_rule_elem stm tgt arity
- (Ast0.FunDecl(bef,fi,name,lp,params,rp,lbrace,body,rbrace))
- | Ast0.Include(inc,s) ->
- let arity =
- all_same true tgt (mcode2line inc) [mcode2arity inc; mcode2arity s] in
- let inc = mcode inc in
- let s = mcode s in
- make_rule_elem stm tgt arity (Ast0.Include(inc,s))
- | Ast0.Define(def,id,params,body) ->
- let arity = all_same true tgt (mcode2line def) [mcode2arity def] in
- let def = mcode def in
- let id = ident false arity id in
- let params = define_parameters arity params in
- let body = dots (statement arity) body in
- make_rule_elem stm tgt arity (Ast0.Define(def,id,params,body))
- | Ast0.OptStm(_) | Ast0.UniqueStm(_) ->
- failwith "unexpected code"
-
-and define_parameters tgt params =
- match Ast0.unwrap params with
- Ast0.NoParams -> params
- | Ast0.DParams(lp,params,rp) ->
- let arity =
- all_same true tgt (mcode2line lp) [mcode2arity lp;mcode2arity rp] in
- let lp = mcode lp in
- let params = dots (define_param arity) params in
- let rp = mcode rp in
- Ast0.rewrap params (Ast0.DParams(lp,params,rp))
-
-and make_define_param x =
- make_opt_unique
- (function x -> Ast0.OptDParam x)
- (function x -> Ast0.UniqueDParam x)
- x
-
-and define_param tgt param =
- match Ast0.unwrap param with
- Ast0.DParam(id) ->
- let new_id = ident true tgt id in
- Ast0.rewrap param
- (match Ast0.unwrap new_id with
- Ast0.OptIdent(id) ->
- Ast0.OptDParam(Ast0.rewrap param (Ast0.DParam(id)))
- | Ast0.UniqueIdent(decl) ->
- Ast0.UniqueDParam(Ast0.rewrap param (Ast0.DParam(id)))
- | _ -> Ast0.DParam(new_id))
- | Ast0.DPComma(cm) ->
- let arity =
- all_same true tgt (mcode2line cm) [mcode2arity cm] in
- let cm = mcode cm in
- make_define_param param tgt arity (Ast0.DPComma(cm))
- | Ast0.DPdots(dots) ->
- let arity =
- all_same true tgt (mcode2line dots) [mcode2arity dots] in
- let dots = mcode dots in
- make_define_param param tgt arity (Ast0.DPdots(dots))
- | Ast0.DPcircles(circles) ->
- let arity =
- all_same true tgt (mcode2line circles) [mcode2arity circles] in
- let circles = mcode circles in
- make_define_param param tgt arity (Ast0.DPcircles(circles))
- | Ast0.OptDParam(dp) | Ast0.UniqueDParam(dp) ->
- failwith "unexpected code"
-
-and fninfo arity = function
- Ast0.FStorage(stg) -> Ast0.FStorage(mcode stg)
- | Ast0.FType(ty) -> Ast0.FType(typeC arity ty)
- | Ast0.FInline(inline) -> Ast0.FInline(mcode inline)
- | Ast0.FAttr(attr) -> Ast0.FAttr(mcode attr)
-
-and fninfo2arity fninfo =
- List.concat
- (List.map
- (function
- Ast0.FStorage(stg) -> [mcode2arity stg]
- | Ast0.FType(ty) -> []
- | Ast0.FInline(inline) -> [mcode2arity inline]
- | Ast0.FAttr(attr) -> [mcode2arity attr])
- fninfo)
-
-and whencode notfn alwaysfn expression = function
- Ast0.WhenNot a -> Ast0.WhenNot (notfn a)
- | Ast0.WhenAlways a -> Ast0.WhenAlways (alwaysfn a)
- | Ast0.WhenModifier(x) -> Ast0.WhenModifier(x)
- | Ast0.WhenNotTrue a -> Ast0.WhenNotTrue (expression a)
- | Ast0.WhenNotFalse a -> Ast0.WhenNotFalse (expression a)
-
-and make_case_line =
- make_opt_unique
- (function x -> Ast0.OptCase x)
- (function x -> failwith "unique not allowed for case_line")
-
-and case_line tgt c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- let arity =
- all_same true tgt (mcode2line def)
- [mcode2arity def; mcode2arity colon] in
- let def = mcode def in
- let colon = mcode colon in
- let code = dots (statement arity) code in
- make_case_line c tgt arity (Ast0.Default(def,colon,code))
- | Ast0.Case(case,exp,colon,code) ->
- let arity =
- all_same true tgt (mcode2line case)
- [mcode2arity case; mcode2arity colon] in
- let case = mcode case in
- let exp = expression arity exp in
- let colon = mcode colon in
- let code = dots (statement arity) code in
- make_case_line c tgt arity (Ast0.Case(case,exp,colon,code))
- | Ast0.OptCase(_) -> failwith "unexpected OptCase"
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-(* Haven't thought much about arity here... *)
-
-let top_level tgt t =
- Ast0.rewrap t
- (match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- if mcode2arity old_file = Ast0.NONE && mcode2arity new_file = Ast0.NONE
- then Ast0.FILEINFO(mcode old_file,mcode new_file)
- else fail t "unexpected arity for file info"
- | Ast0.DECL(stmt) ->
- Ast0.DECL(statement tgt stmt)
- | Ast0.CODE(rule_elem_dots) ->
- Ast0.CODE(concat_dots (statement tgt) rule_elem_dots)
- | Ast0.ERRORWORDS(exps) ->
- Ast0.ERRORWORDS(List.map (top_expression false Ast0.NONE) exps)
- | Ast0.OTHER(_) -> fail t "eliminated by top_level")
-
-let rule tgt = List.map (top_level tgt)
-
-(* --------------------------------------------------------------------- *)
-(* Entry points *)
-
-let minus_arity code =
- rule Ast0.NONE code
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-type arity = OPT | UNIQUE | NONE
-
-type token_info =
- { tline_start : int; tline_end : int;
- left_offset : int; right_offset : int }
-let default_token_info =
- { tline_start = -1; tline_end = -1; left_offset = -1; right_offset = -1 }
-
-(* MIXED is like CONTEXT, since sometimes MIXED things have to revert to
-CONTEXT - see insert_plus.ml *)
-type mcodekind =
- MINUS of (Ast.anything list list * token_info) ref
- | PLUS
- | CONTEXT of (Ast.anything Ast.befaft * token_info * token_info) ref
- | MIXED of (Ast.anything Ast.befaft * token_info * token_info) ref
-
-type info = { line_start : int; line_end : int;
- logical_start : int; logical_end : int;
- attachable_start : bool; attachable_end : bool;
- mcode_start : mcodekind list; mcode_end : mcodekind list;
- column : int; offset : int;
- (* the following are only for + code *)
- strings_before : string list; strings_after : string list }
-
-type 'a mcode = 'a * arity * info * mcodekind * meta_pos ref (* pos, - only *)
-(* int ref is an index *)
-and 'a wrap =
- { node : 'a;
- info : info;
- index : int ref;
- mcodekind : mcodekind ref;
- exp_ty : Type_cocci.typeC option ref; (* only for expressions *)
- bef_aft : dots_bef_aft; (* only for statements *)
- true_if_arg : bool; (* true if "arg_exp", only for exprs *)
- true_if_test : bool; (* true if "test position", only for exprs *)
- true_if_test_exp : bool;(* true if "test_exp from iso", only for exprs *)
- (*nonempty if this represents the use of an iso*)
- iso_info : (string*anything) list }
-
-and dots_bef_aft =
- NoDots | AddingBetweenDots of statement | DroppingBetweenDots of statement
-
-(* for iso metavariables, true if they can only match nonmodified terms with
- all metavariables unitary
- for SP metavariables, true if the metavariable is unitary (valid up to
- isomorphism phase only)
- In SP, the only options are impure and context
-*)
-and pure = Impure | Pure | Context | PureContext (* pure and only context *)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-and 'a base_dots =
- DOTS of 'a list
- | CIRCLES of 'a list
- | STARS of 'a list
-
-and 'a dots = 'a base_dots wrap
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-and base_ident =
- Id of string mcode
- | MetaId of Ast.meta_name mcode * ident list * pure
- | MetaFunc of Ast.meta_name mcode * ident list * pure
- | MetaLocalFunc of Ast.meta_name mcode * ident list * pure
- | OptIdent of ident
- | UniqueIdent of ident
-
-and ident = base_ident wrap
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-and base_expression =
- Ident of ident
- | Constant of Ast.constant mcode
- | FunCall of expression * string mcode (* ( *) *
- expression dots * string mcode (* ) *)
- | Assignment of expression * Ast.assignOp mcode * expression *
- bool (* true if it can match an initialization *)
- | CondExpr of expression * string mcode (* ? *) * expression option *
- string mcode (* : *) * expression
- | Postfix of expression * Ast.fixOp mcode
- | Infix of expression * Ast.fixOp mcode
- | Unary of expression * Ast.unaryOp mcode
- | Binary of expression * Ast.binaryOp mcode * expression
- | Nested of expression * Ast.binaryOp mcode * expression
- | Paren of string mcode (* ( *) * expression *
- string mcode (* ) *)
- | ArrayAccess of expression * string mcode (* [ *) * expression *
- string mcode (* ] *)
- | RecordAccess of expression * string mcode (* . *) * ident
- | RecordPtAccess of expression * string mcode (* -> *) * ident
- | Cast of string mcode (* ( *) * typeC * string mcode (* ) *) *
- expression
- | SizeOfExpr of string mcode (* sizeof *) * expression
- | SizeOfType of string mcode (* sizeof *) * string mcode (* ( *) *
- typeC * string mcode (* ) *)
- | TypeExp of typeC (* type name used as an expression, only in args *)
- | MetaErr of Ast.meta_name mcode * expression list * pure
- | MetaExpr of Ast.meta_name mcode * expression list *
- Type_cocci.typeC list option * Ast.form * pure
- | MetaExprList of Ast.meta_name mcode (* only in arg lists *) *
- listlen * pure
- | EComma of string mcode (* only in arg lists *)
- | DisjExpr of string mcode * expression list *
- string mcode list (* the |s *) * string mcode
- | NestExpr of string mcode * expression dots * string mcode *
- expression option * Ast.multi
- | Edots of string mcode (* ... *) * expression option
- | Ecircles of string mcode (* ooo *) * expression option
- | Estars of string mcode (* *** *) * expression option
- | OptExp of expression
- | UniqueExp of expression
-
-and expression = base_expression wrap
-
-and listlen = Ast.meta_name mcode option
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and base_typeC =
- ConstVol of Ast.const_vol mcode * typeC
- | BaseType of Ast.baseType * string mcode list
- | Signed of Ast.sign mcode * typeC option
- | Pointer of typeC * string mcode (* * *)
- | FunctionPointer of typeC *
- string mcode(* ( *)*string mcode(* * *)*string mcode(* ) *)*
- string mcode (* ( *)*parameter_list*string mcode(* ) *)
- | FunctionType of typeC option *
- string mcode (* ( *) * parameter_list *
- string mcode (* ) *)
- | Array of typeC * string mcode (* [ *) *
- expression option * string mcode (* ] *)
- | EnumName of string mcode (*enum*) * ident (* name *)
- | StructUnionName of Ast.structUnion mcode * ident option (* name *)
- | StructUnionDef of typeC (* either StructUnionName or metavar *) *
- string mcode (* { *) * declaration dots * string mcode (* } *)
- | TypeName of string mcode
- | MetaType of Ast.meta_name mcode * pure
- | DisjType of string mcode * typeC list * (* only after iso *)
- string mcode list (* the |s *) * string mcode
- | OptType of typeC
- | UniqueType of typeC
-
-and typeC = base_typeC wrap
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and base_declaration =
- Init of Ast.storage mcode option * typeC * ident * string mcode (*=*) *
- initialiser * string mcode (*;*)
- | UnInit of Ast.storage mcode option * typeC * ident * string mcode (* ; *)
- | TyDecl of typeC * string mcode (* ; *)
- | MacroDecl of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *) * string mcode (* ; *)
- | Typedef of string mcode (* typedef *) * typeC * typeC * string mcode (*;*)
- | DisjDecl of string mcode * declaration list *
- string mcode list (* the |s *) * string mcode
- (* Ddots is for a structure declaration *)
- | Ddots of string mcode (* ... *) * declaration option (* whencode *)
- | OptDecl of declaration
- | UniqueDecl of declaration
-
-and declaration = base_declaration wrap
-
-(* --------------------------------------------------------------------- *)
-(* Initializers *)
-
-and base_initialiser =
- InitExpr of expression
- | InitList of string mcode (*{*) * initialiser_list * string mcode (*}*)
- | InitGccDotName of
- string mcode (*.*) * ident (* name *) * string mcode (*=*) *
- initialiser (* gccext: *)
- | InitGccName of ident (* name *) * string mcode (*:*) *
- initialiser
- | InitGccIndex of
- string mcode (*[*) * expression * string mcode (*]*) *
- string mcode (*=*) * initialiser
- | InitGccRange of
- string mcode (*[*) * expression * string mcode (*...*) *
- expression * string mcode (*]*) * string mcode (*=*) * initialiser
- | IComma of string mcode (* , *)
- | Idots of string mcode (* ... *) * initialiser option (* whencode *)
- | OptIni of initialiser
- | UniqueIni of initialiser
-
-and initialiser = base_initialiser wrap
-
-and initialiser_list = initialiser dots
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and base_parameterTypeDef =
- VoidParam of typeC
- | Param of typeC * ident option
- | MetaParam of Ast.meta_name mcode * pure
- | MetaParamList of Ast.meta_name mcode * listlen * pure
- | PComma of string mcode
- | Pdots of string mcode (* ... *)
- | Pcircles of string mcode (* ooo *)
- | OptParam of parameterTypeDef
- | UniqueParam of parameterTypeDef
-
-and parameterTypeDef = base_parameterTypeDef wrap
-
-and parameter_list = parameterTypeDef dots
-
-(* --------------------------------------------------------------------- *)
-(* #define Parameters *)
-
-and base_define_param =
- DParam of ident
- | DPComma of string mcode
- | DPdots of string mcode (* ... *)
- | DPcircles of string mcode (* ooo *)
- | OptDParam of define_param
- | UniqueDParam of define_param
-
-and define_param = base_define_param wrap
-
-and base_define_parameters =
- NoParams
- | DParams of string mcode(*( *) * define_param dots * string mcode(* )*)
-
-and define_parameters = base_define_parameters wrap
-
-(* --------------------------------------------------------------------- *)
-(* Statement*)
-
-and base_statement =
- Decl of (info * mcodekind) (* before the decl *) * declaration
- | Seq of string mcode (* { *) * statement dots *
- string mcode (* } *)
- | ExprStatement of expression * string mcode (*;*)
- | IfThen of string mcode (* if *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- statement * (info * mcodekind) (* after info *)
- | IfThenElse of string mcode (* if *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- statement * string mcode (* else *) * statement *
- (info * mcodekind)
- | While of string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- statement * (info * mcodekind) (* after info *)
- | Do of string mcode (* do *) * statement *
- string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- string mcode (* ; *)
- | For of string mcode (* for *) * string mcode (* ( *) *
- expression option * string mcode (*;*) *
- expression option * string mcode (*;*) *
- expression option * string mcode (* ) *) * statement *
- (info * mcodekind) (* after info *)
- | Iterator of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *) *
- statement * (info * mcodekind) (* after info *)
- | Switch of string mcode (* switch *) * string mcode (* ( *) *
- expression * string mcode (* ) *) * string mcode (* { *) *
- case_line dots * string mcode (* } *)
- | Break of string mcode (* break *) * string mcode (* ; *)
- | Continue of string mcode (* continue *) * string mcode (* ; *)
- | Label of ident * string mcode (* : *)
- | Goto of string mcode (* goto *) * ident * string mcode (* ; *)
- | Return of string mcode (* return *) * string mcode (* ; *)
- | ReturnExpr of string mcode (* return *) * expression *
- string mcode (* ; *)
- | MetaStmt of Ast.meta_name mcode * pure
- | MetaStmtList of Ast.meta_name mcode(*only in statement lists*) * pure
- | Exp of expression (* only in dotted statement lists *)
- | TopExp of expression (* for macros body *)
- | Ty of typeC (* only at top level *)
- | TopInit of initialiser (* only at top level *)
- | Disj of string mcode * statement dots list *
- string mcode list (* the |s *) * string mcode
- | Nest of string mcode * statement dots * string mcode *
- (statement dots,statement) whencode list * Ast.multi
- | Dots of string mcode (* ... *) *
- (statement dots,statement) whencode list
- | Circles of string mcode (* ooo *) *
- (statement dots,statement) whencode list
- | Stars of string mcode (* *** *) *
- (statement dots,statement) whencode list
- | FunDecl of (info * mcodekind) (* before the function decl *) *
- fninfo list * ident (* name *) *
- string mcode (* ( *) * parameter_list * string mcode (* ) *) *
- string mcode (* { *) * statement dots *
- string mcode (* } *)
- | Include of string mcode (* #include *) * Ast.inc_file mcode (* file *)
- | Define of string mcode (* #define *) * ident (* name *) *
- define_parameters (*params*) * statement dots
- | OptStm of statement
- | UniqueStm of statement
-
-and fninfo =
- FStorage of Ast.storage mcode
- | FType of typeC
- | FInline of string mcode
- | FAttr of string mcode
-
-and ('a,'b) whencode =
- WhenNot of 'a
- | WhenAlways of 'b
- | WhenModifier of Ast.when_modifier
- | WhenNotTrue of expression
- | WhenNotFalse of expression
-
-and statement = base_statement wrap
-
-and base_case_line =
- Default of string mcode (* default *) * string mcode (*:*) * statement dots
- | Case of string mcode (* case *) * expression * string mcode (*:*) *
- statement dots
- | OptCase of case_line
-
-and case_line = base_case_line wrap
-
-(* --------------------------------------------------------------------- *)
-(* Positions *)
-
-and meta_pos =
- MetaPos of Ast.meta_name mcode * Ast.meta_name list * Ast.meta_collect
- | NoMetaPos
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and base_top_level =
- DECL of statement
- | CODE of statement dots
- | FILEINFO of string mcode (* old file *) * string mcode (* new file *)
- | ERRORWORDS of expression list
- | OTHER of statement (* temporary, disappears after top_level.ml *)
-
-and top_level = base_top_level wrap
-and rule = top_level list
-
-and parsed_rule =
- CocciRule of
- (rule * Ast.metavar list *
- (string list * string list * Ast.dependency * string * Ast.exists)) *
- (rule * Ast.metavar list) * Ast.ruletype
- | ScriptRule of
- string * Ast.dependency * (string * Ast.meta_name) list * string
-
-(* --------------------------------------------------------------------- *)
-
-and anything =
- DotsExprTag of expression dots
- | DotsInitTag of initialiser dots
- | DotsParamTag of parameterTypeDef dots
- | DotsStmtTag of statement dots
- | DotsDeclTag of declaration dots
- | DotsCaseTag of case_line dots
- | IdentTag of ident
- | ExprTag of expression
- | ArgExprTag of expression (* for isos *)
- | TestExprTag of expression (* for isos *)
- | TypeCTag of typeC
- | ParamTag of parameterTypeDef
- | InitTag of initialiser
- | DeclTag of declaration
- | StmtTag of statement
- | CaseLineTag of case_line
- | TopTag of top_level
- | IsoWhenTag of Ast.when_modifier
- | IsoWhenTTag of expression
- | IsoWhenFTag of expression
- | MetaPosTag of meta_pos
-
-let dotsExpr x = DotsExprTag x
-let dotsParam x = DotsParamTag x
-let dotsInit x = DotsInitTag x
-let dotsStmt x = DotsStmtTag x
-let dotsDecl x = DotsDeclTag x
-let dotsCase x = DotsCaseTag x
-let ident x = IdentTag x
-let expr x = ExprTag x
-let typeC x = TypeCTag x
-let param x = ParamTag x
-let ini x = InitTag x
-let decl x = DeclTag x
-let stmt x = StmtTag x
-let case_line x = CaseLineTag x
-let top x = TopTag x
-
-(* --------------------------------------------------------------------- *)
-(* Avoid cluttering the parser. Calculated in compute_lines.ml. *)
-
-let default_info _ = (* why is this a function? *)
- { line_start = -1; line_end = -1;
- logical_start = -1; logical_end = -1;
- attachable_start = true; attachable_end = true;
- mcode_start = []; mcode_end = [];
- column = -1; offset = -1; strings_before = []; strings_after = [] }
-
-let default_befaft _ =
- MIXED(ref (Ast.NOTHING,default_token_info,default_token_info))
-let context_befaft _ =
- CONTEXT(ref (Ast.NOTHING,default_token_info,default_token_info))
-
-let wrap x =
- { node = x;
- info = default_info();
- index = ref (-1);
- mcodekind = ref (default_befaft());
- exp_ty = ref None;
- bef_aft = NoDots;
- true_if_arg = false;
- true_if_test = false;
- true_if_test_exp = false;
- iso_info = [] }
-let context_wrap x =
- { node = x;
- info = default_info();
- index = ref (-1);
- mcodekind = ref (context_befaft());
- exp_ty = ref None;
- bef_aft = NoDots;
- true_if_arg = false;
- true_if_test = false;
- true_if_test_exp = false;
- iso_info = [] }
-let unwrap x = x.node
-let unwrap_mcode (x,_,_,_,_) = x
-let rewrap model x = { model with node = x }
-let rewrap_mcode (_,arity,info,mcodekind,pos) x = (x,arity,info,mcodekind,pos)
-let copywrap model x =
- { model with node = x; index = ref !(model.index);
- mcodekind = ref !(model.mcodekind); exp_ty = ref !(model.exp_ty)}
-let get_pos (_,_,_,_,x) = !x
-let get_pos_ref (_,_,_,_,x) = x
-let set_pos pos (m,arity,info,mcodekind,_) = (m,arity,info,mcodekind,ref pos)
-let get_info x = x.info
-let set_info x info = {x with info = info}
-let get_line x = x.info.line_start
-let get_line_end x = x.info.line_end
-let get_index x = !(x.index)
-let set_index x i = x.index := i
-let get_mcodekind x = !(x.mcodekind)
-let get_mcode_mcodekind (_,_,_,mcodekind,_) = mcodekind
-let get_mcodekind_ref x = x.mcodekind
-let set_mcodekind x mk = x.mcodekind := mk
-let set_type x t = x.exp_ty := t
-let get_type x = !(x.exp_ty)
-let get_dots_bef_aft x = x.bef_aft
-let set_dots_bef_aft x dots_bef_aft = {x with bef_aft = dots_bef_aft}
-let get_arg_exp x = x.true_if_arg
-let set_arg_exp x = {x with true_if_arg = true}
-let get_test_pos x = x.true_if_test
-let set_test_pos x = {x with true_if_test = true}
-let get_test_exp x = x.true_if_test_exp
-let set_test_exp x = {x with true_if_test_exp = true}
-let get_iso x = x.iso_info
-let set_iso x i = if !Flag.track_iso_usage then {x with iso_info = i} else x
-let set_mcode_data data (_,ar,info,mc,pos) = (data,ar,info,mc,pos)
-
-(* --------------------------------------------------------------------- *)
-
-(* unique indices, for mcode and tree nodes *)
-let index_counter = ref 0
-let fresh_index _ = let cur = !index_counter in index_counter := cur + 1; cur
-
-(* --------------------------------------------------------------------- *)
-
-let undots d =
- match unwrap d with
- | DOTS e -> e
- | CIRCLES e -> e
- | STARS e -> e
-
-(* --------------------------------------------------------------------- *)
-
-let rec ast0_type_to_type ty =
- match unwrap ty with
- ConstVol(cv,ty) -> Type_cocci.ConstVol(const_vol cv,ast0_type_to_type ty)
- | BaseType(bty,strings) ->
- Type_cocci.BaseType(baseType bty)
- | Signed(sgn,None) ->
- Type_cocci.SignedT(sign sgn,None)
- | Signed(sgn,Some ty) ->
- let bty = ast0_type_to_type ty in
- Type_cocci.SignedT(sign sgn,Some bty)
- | Pointer(ty,_) -> Type_cocci.Pointer(ast0_type_to_type ty)
- | FunctionPointer(ty,_,_,_,_,params,_) ->
- Type_cocci.FunctionPointer(ast0_type_to_type ty)
- | FunctionType _ -> failwith "not supported"
- | Array(ety,_,_,_) -> Type_cocci.Array(ast0_type_to_type ety)
- | EnumName(su,tag) ->
- (match unwrap tag with
- Id(tag) ->
- Type_cocci.EnumName(false,unwrap_mcode tag)
- | MetaId(tag,_,_) ->
- (Printf.printf
- "warning: enum with a metavariable name detected.\n";
- Printf.printf
- "For type checking assuming the name of the metavariable is the name of the type\n";
- let (rule,tag) = unwrap_mcode tag in
- Type_cocci.EnumName(true,rule^tag))
- | _ -> failwith "unexpected enum type name")
- | StructUnionName(su,Some tag) ->
- (match unwrap tag with
- Id(tag) ->
- Type_cocci.StructUnionName(structUnion su,false,unwrap_mcode tag)
- | MetaId(tag,_,_) ->
- (Printf.printf
- "warning: struct/union with a metavariable name detected.\n";
- Printf.printf
- "For type checking assuming the name of the metavariable is the name of the type\n";
- let (rule,tag) = unwrap_mcode tag in
- Type_cocci.StructUnionName(structUnion su,true,rule^tag))
- | _ -> failwith "unexpected struct/union type name")
- | StructUnionName(su,None) -> failwith "nameless structure - what to do???"
- | StructUnionDef(ty,_,_,_) -> ast0_type_to_type ty
- | TypeName(name) -> Type_cocci.TypeName(unwrap_mcode name)
- | MetaType(name,_) ->
- Type_cocci.MetaType(unwrap_mcode name,Type_cocci.Unitary,false)
- | DisjType(_,types,_,_) -> failwith "unexpected DisjType"
- | OptType(ty) | UniqueType(ty) ->
- ast0_type_to_type ty
-
-and baseType = function
- Ast.VoidType -> Type_cocci.VoidType
- | Ast.CharType -> Type_cocci.CharType
- | Ast.ShortType -> Type_cocci.ShortType
- | Ast.IntType -> Type_cocci.IntType
- | Ast.DoubleType -> Type_cocci.DoubleType
- | Ast.FloatType -> Type_cocci.FloatType
- | Ast.LongType -> Type_cocci.LongType
- | Ast.LongLongType -> Type_cocci.LongLongType
-
-and structUnion t =
- match unwrap_mcode t with
- Ast.Struct -> Type_cocci.Struct
- | Ast.Union -> Type_cocci.Union
-
-and sign t =
- match unwrap_mcode t with
- Ast.Signed -> Type_cocci.Signed
- | Ast.Unsigned -> Type_cocci.Unsigned
-
-and const_vol t =
- match unwrap_mcode t with
- Ast.Const -> Type_cocci.Const
- | Ast.Volatile -> Type_cocci.Volatile
-
-(* --------------------------------------------------------------------- *)
-(* this function is a rather minimal attempt. the problem is that information
-has been lost. but since it is only used for metavariable types in the isos,
-perhaps it doesn't matter *)
-and make_mcode x = (x,NONE,default_info(),context_befaft(),ref NoMetaPos)
-let make_mcode_info x info = (x,NONE,info,context_befaft(),ref NoMetaPos)
-
-exception TyConv
-
-let rec reverse_type ty =
- match ty with
- Type_cocci.ConstVol(cv,ty) ->
- ConstVol(reverse_const_vol cv,context_wrap(reverse_type ty))
- | Type_cocci.BaseType(bty) ->
- BaseType(reverse_baseType bty,[(* not used *)])
- | Type_cocci.SignedT(sgn,None) -> Signed(reverse_sign sgn,None)
- | Type_cocci.SignedT(sgn,Some bty) ->
- Signed(reverse_sign sgn,Some (context_wrap(reverse_type ty)))
- | Type_cocci.Pointer(ty) ->
- Pointer(context_wrap(reverse_type ty),make_mcode "*")
- | Type_cocci.EnumName(mv,tag) ->
- if mv
- then
- (* not right... *)
- EnumName
- (make_mcode "enum",
- context_wrap(MetaId(make_mcode ("",tag),[],Impure)))
- else
- EnumName(make_mcode "enum",context_wrap(Id(make_mcode tag)))
- | Type_cocci.StructUnionName(su,mv,tag) ->
- if mv
- then
- (* not right... *)
- StructUnionName
- (reverse_structUnion su,
- Some(context_wrap(MetaId(make_mcode ("",tag),[],Impure))))
- else
- StructUnionName
- (reverse_structUnion su,
- Some (context_wrap(Id(make_mcode tag))))
- | Type_cocci.TypeName(name) -> TypeName(make_mcode name)
- | Type_cocci.MetaType(name,_,_) ->
- MetaType(make_mcode name,Impure(*not really right*))
- | _ -> raise TyConv
-
-and reverse_baseType = function
- Type_cocci.VoidType -> Ast.VoidType
- | Type_cocci.CharType -> Ast.CharType
- | Type_cocci.BoolType -> Ast.IntType
- | Type_cocci.ShortType -> Ast.ShortType
- | Type_cocci.IntType -> Ast.IntType
- | Type_cocci.DoubleType -> Ast.DoubleType
- | Type_cocci.FloatType -> Ast.FloatType
- | Type_cocci.LongType -> Ast.LongType
- | Type_cocci.LongLongType -> Ast.LongLongType
-
-and reverse_structUnion t =
- make_mcode
- (match t with
- Type_cocci.Struct -> Ast.Struct
- | Type_cocci.Union -> Ast.Union)
-
-and reverse_sign t =
- make_mcode
- (match t with
- Type_cocci.Signed -> Ast.Signed
- | Type_cocci.Unsigned -> Ast.Unsigned)
-
-and reverse_const_vol t =
- make_mcode
- (match t with
- Type_cocci.Const -> Ast.Const
- | Type_cocci.Volatile -> Ast.Volatile)
-
-(* --------------------------------------------------------------------- *)
-
-let lub_pure x y =
- match (x,y) with
- (Impure,_) | (_,Impure) -> Impure
- | (Pure,Context) | (Context,Pure) -> Impure
- | (Pure,_) | (_,Pure) -> Pure
- | (_,Context) | (Context,_) -> Context
- | _ -> PureContext
-
-(* --------------------------------------------------------------------- *)
-
-let rule_name = ref "" (* for the convenience of the parser *)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-type arity = OPT | UNIQUE | NONE
-
-type token_info =
- { tline_start : int; tline_end : int;
- left_offset : int; right_offset : int }
-let default_token_info =
- { tline_start = -1; tline_end = -1; left_offset = -1; right_offset = -1 }
-
-(* MIXED is like CONTEXT, since sometimes MIXED things have to revert to
-CONTEXT - see insert_plus.ml *)
-type mcodekind =
- MINUS of (Ast.anything list list * token_info) ref
- | PLUS
- | CONTEXT of (Ast.anything Ast.befaft * token_info * token_info) ref
- | MIXED of (Ast.anything Ast.befaft * token_info * token_info) ref
-
-type info = { line_start : int; line_end : int;
- logical_start : int; logical_end : int;
- attachable_start : bool; attachable_end : bool;
- mcode_start : mcodekind list; mcode_end : mcodekind list;
- column : int; offset : int;
- (* the following are only for + code *)
- strings_before : string list; strings_after : string list }
-
-type 'a mcode = 'a * arity * info * mcodekind * meta_pos ref (* pos, - only *)
-(* int ref is an index *)
-and 'a wrap =
- { node : 'a;
- info : info;
- index : int ref;
- mcodekind : mcodekind ref;
- exp_ty : Type_cocci.typeC option ref; (* only for expressions *)
- bef_aft : dots_bef_aft; (* only for statements *)
- true_if_arg : bool; (* true if "arg_exp", only for exprs *)
- true_if_test : bool; (* true if "test position", only for exprs *)
- true_if_test_exp : bool;(* true if "test_exp from iso", only for exprs *)
- (*nonempty if this represents the use of an iso*)
- iso_info : (string*anything) list }
-
-and dots_bef_aft =
- NoDots | AddingBetweenDots of statement | DroppingBetweenDots of statement
-
-(* for iso metavariables, true if they can only match nonmodified terms with
- all metavariables unitary
- for SP metavariables, true if the metavariable is unitary (valid up to
- isomorphism phase only)
- In SP, the only options are impure and context
-*)
-and pure = Impure | Pure | Context | PureContext (* pure and only context *)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-and 'a base_dots =
- DOTS of 'a list
- | CIRCLES of 'a list
- | STARS of 'a list
-
-and 'a dots = 'a base_dots wrap
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-and base_ident =
- Id of string mcode
- | MetaId of Ast.meta_name mcode * ident list * pure
- | MetaFunc of Ast.meta_name mcode * ident list * pure
- | MetaLocalFunc of Ast.meta_name mcode * ident list * pure
- | OptIdent of ident
- | UniqueIdent of ident
-
-and ident = base_ident wrap
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-and base_expression =
- Ident of ident
- | Constant of Ast.constant mcode
- | FunCall of expression * string mcode (* ( *) *
- expression dots * string mcode (* ) *)
- | Assignment of expression * Ast.assignOp mcode * expression *
- bool (* true if it can match an initialization *)
- | CondExpr of expression * string mcode (* ? *) * expression option *
- string mcode (* : *) * expression
- | Postfix of expression * Ast.fixOp mcode
- | Infix of expression * Ast.fixOp mcode
- | Unary of expression * Ast.unaryOp mcode
- | Binary of expression * Ast.binaryOp mcode * expression
- | Nested of expression * Ast.binaryOp mcode * expression
- | Paren of string mcode (* ( *) * expression *
- string mcode (* ) *)
- | ArrayAccess of expression * string mcode (* [ *) * expression *
- string mcode (* ] *)
- | RecordAccess of expression * string mcode (* . *) * ident
- | RecordPtAccess of expression * string mcode (* -> *) * ident
- | Cast of string mcode (* ( *) * typeC * string mcode (* ) *) *
- expression
- | SizeOfExpr of string mcode (* sizeof *) * expression
- | SizeOfType of string mcode (* sizeof *) * string mcode (* ( *) *
- typeC * string mcode (* ) *)
- | TypeExp of typeC (* type name used as an expression, only in args *)
- | MetaErr of Ast.meta_name mcode * expression list * pure
- | MetaExpr of Ast.meta_name mcode * expression list *
- Type_cocci.typeC list option * Ast.form * pure
- | MetaExprList of Ast.meta_name mcode (* only in arg lists *) *
- listlen * pure
- | EComma of string mcode (* only in arg lists *)
- | DisjExpr of string mcode * expression list *
- string mcode list (* the |s *) * string mcode
- | NestExpr of string mcode * expression dots * string mcode *
- expression option * Ast.multi
- | Edots of string mcode (* ... *) * expression option
- | Ecircles of string mcode (* ooo *) * expression option
- | Estars of string mcode (* *** *) * expression option
- | OptExp of expression
- | UniqueExp of expression
-
-and expression = base_expression wrap
-
-and listlen = Ast.meta_name mcode option
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and base_typeC =
- ConstVol of Ast.const_vol mcode * typeC
- | BaseType of Ast.baseType * string mcode list
- | Signed of Ast.sign mcode * typeC option
- | Pointer of typeC * string mcode (* * *)
- | FunctionPointer of typeC *
- string mcode(* ( *)*string mcode(* * *)*string mcode(* ) *)*
- string mcode (* ( *)*parameter_list*string mcode(* ) *)
- | FunctionType of typeC option *
- string mcode (* ( *) * parameter_list *
- string mcode (* ) *)
- | Array of typeC * string mcode (* [ *) *
- expression option * string mcode (* ] *)
- | EnumName of string mcode (*enum*) * ident (* name *)
- | StructUnionName of Ast.structUnion mcode * ident option (* name *)
- | StructUnionDef of typeC (* either StructUnionName or metavar *) *
- string mcode (* { *) * declaration dots * string mcode (* } *)
- | TypeName of string mcode
- | MetaType of Ast.meta_name mcode * pure
- | DisjType of string mcode * typeC list * (* only after iso *)
- string mcode list (* the |s *) * string mcode
- | OptType of typeC
- | UniqueType of typeC
-
-and typeC = base_typeC wrap
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and base_declaration =
- Init of Ast.storage mcode option * typeC * ident * string mcode (*=*) *
- initialiser * string mcode (*;*)
- | UnInit of Ast.storage mcode option * typeC * ident * string mcode (* ; *)
- | TyDecl of typeC * string mcode (* ; *)
- | MacroDecl of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *) * string mcode (* ; *)
- | Typedef of string mcode (* typedef *) * typeC * typeC * string mcode (*;*)
- | DisjDecl of string mcode * declaration list *
- string mcode list (* the |s *) * string mcode
- (* Ddots is for a structure declaration *)
- | Ddots of string mcode (* ... *) * declaration option (* whencode *)
- | OptDecl of declaration
- | UniqueDecl of declaration
-
-and declaration = base_declaration wrap
-
-(* --------------------------------------------------------------------- *)
-(* Initializers *)
-
-and base_initialiser =
- MetaInit of Ast.meta_name mcode * pure
- | InitExpr of expression
- | InitList of string mcode (*{*) * initialiser_list * string mcode (*}*)
- | InitGccExt of
- designator list (* name *) * string mcode (*=*) *
- initialiser (* gccext: *)
- | InitGccName of ident (* name *) * string mcode (*:*) *
- initialiser
- | IComma of string mcode (* , *)
- | Idots of string mcode (* ... *) * initialiser option (* whencode *)
- | OptIni of initialiser
- | UniqueIni of initialiser
-
-and designator =
- DesignatorField of string mcode (* . *) * ident
- | DesignatorIndex of string mcode (* [ *) * expression * string mcode (* ] *)
- | DesignatorRange of
- string mcode (* [ *) * expression * string mcode (* ... *) *
- expression * string mcode (* ] *)
-
-and initialiser = base_initialiser wrap
-
-and initialiser_list = initialiser dots
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and base_parameterTypeDef =
- VoidParam of typeC
- | Param of typeC * ident option
- | MetaParam of Ast.meta_name mcode * pure
- | MetaParamList of Ast.meta_name mcode * listlen * pure
- | PComma of string mcode
- | Pdots of string mcode (* ... *)
- | Pcircles of string mcode (* ooo *)
- | OptParam of parameterTypeDef
- | UniqueParam of parameterTypeDef
-
-and parameterTypeDef = base_parameterTypeDef wrap
-
-and parameter_list = parameterTypeDef dots
-
-(* --------------------------------------------------------------------- *)
-(* #define Parameters *)
-
-and base_define_param =
- DParam of ident
- | DPComma of string mcode
- | DPdots of string mcode (* ... *)
- | DPcircles of string mcode (* ooo *)
- | OptDParam of define_param
- | UniqueDParam of define_param
-
-and define_param = base_define_param wrap
-
-and base_define_parameters =
- NoParams
- | DParams of string mcode(*( *) * define_param dots * string mcode(* )*)
-
-and define_parameters = base_define_parameters wrap
-
-(* --------------------------------------------------------------------- *)
-(* Statement*)
-
-and base_statement =
- Decl of (info * mcodekind) (* before the decl *) * declaration
- | Seq of string mcode (* { *) * statement dots *
- string mcode (* } *)
- | ExprStatement of expression * string mcode (*;*)
- | IfThen of string mcode (* if *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- statement * (info * mcodekind) (* after info *)
- | IfThenElse of string mcode (* if *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- statement * string mcode (* else *) * statement *
- (info * mcodekind)
- | While of string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- statement * (info * mcodekind) (* after info *)
- | Do of string mcode (* do *) * statement *
- string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- string mcode (* ; *)
- | For of string mcode (* for *) * string mcode (* ( *) *
- expression option * string mcode (*;*) *
- expression option * string mcode (*;*) *
- expression option * string mcode (* ) *) * statement *
- (info * mcodekind) (* after info *)
- | Iterator of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *) *
- statement * (info * mcodekind) (* after info *)
- | Switch of string mcode (* switch *) * string mcode (* ( *) *
- expression * string mcode (* ) *) * string mcode (* { *) *
- case_line dots * string mcode (* } *)
- | Break of string mcode (* break *) * string mcode (* ; *)
- | Continue of string mcode (* continue *) * string mcode (* ; *)
- | Label of ident * string mcode (* : *)
- | Goto of string mcode (* goto *) * ident * string mcode (* ; *)
- | Return of string mcode (* return *) * string mcode (* ; *)
- | ReturnExpr of string mcode (* return *) * expression *
- string mcode (* ; *)
- | MetaStmt of Ast.meta_name mcode * pure
- | MetaStmtList of Ast.meta_name mcode(*only in statement lists*) * pure
- | Exp of expression (* only in dotted statement lists *)
- | TopExp of expression (* for macros body *)
- | Ty of typeC (* only at top level *)
- | TopInit of initialiser (* only at top level *)
- | Disj of string mcode * statement dots list *
- string mcode list (* the |s *) * string mcode
- | Nest of string mcode * statement dots * string mcode *
- (statement dots,statement) whencode list * Ast.multi
- | Dots of string mcode (* ... *) *
- (statement dots,statement) whencode list
- | Circles of string mcode (* ooo *) *
- (statement dots,statement) whencode list
- | Stars of string mcode (* *** *) *
- (statement dots,statement) whencode list
- | FunDecl of (info * mcodekind) (* before the function decl *) *
- fninfo list * ident (* name *) *
- string mcode (* ( *) * parameter_list * string mcode (* ) *) *
- string mcode (* { *) * statement dots *
- string mcode (* } *)
- | Include of string mcode (* #include *) * Ast.inc_file mcode (* file *)
- | Define of string mcode (* #define *) * ident (* name *) *
- define_parameters (*params*) * statement dots
- | OptStm of statement
- | UniqueStm of statement
-
-and fninfo =
- FStorage of Ast.storage mcode
- | FType of typeC
- | FInline of string mcode
- | FAttr of string mcode
-
-and ('a,'b) whencode =
- WhenNot of 'a
- | WhenAlways of 'b
- | WhenModifier of Ast.when_modifier
- | WhenNotTrue of expression
- | WhenNotFalse of expression
-
-and statement = base_statement wrap
-
-and base_case_line =
- Default of string mcode (* default *) * string mcode (*:*) * statement dots
- | Case of string mcode (* case *) * expression * string mcode (*:*) *
- statement dots
- | OptCase of case_line
-
-and case_line = base_case_line wrap
-
-(* --------------------------------------------------------------------- *)
-(* Positions *)
-
-and meta_pos =
- MetaPos of Ast.meta_name mcode * Ast.meta_name list * Ast.meta_collect
- | NoMetaPos
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and base_top_level =
- DECL of statement
- | CODE of statement dots
- | FILEINFO of string mcode (* old file *) * string mcode (* new file *)
- | ERRORWORDS of expression list
- | OTHER of statement (* temporary, disappears after top_level.ml *)
-
-and top_level = base_top_level wrap
-and rule = top_level list
-
-and parsed_rule =
- CocciRule of
- (rule * Ast.metavar list *
- (string list * string list * Ast.dependency * string * Ast.exists)) *
- (rule * Ast.metavar list) * Ast.ruletype
- | ScriptRule of
- string * Ast.dependency * (string * Ast.meta_name) list * string
-
-(* --------------------------------------------------------------------- *)
-
-and anything =
- DotsExprTag of expression dots
- | DotsInitTag of initialiser dots
- | DotsParamTag of parameterTypeDef dots
- | DotsStmtTag of statement dots
- | DotsDeclTag of declaration dots
- | DotsCaseTag of case_line dots
- | IdentTag of ident
- | ExprTag of expression
- | ArgExprTag of expression (* for isos *)
- | TestExprTag of expression (* for isos *)
- | TypeCTag of typeC
- | ParamTag of parameterTypeDef
- | InitTag of initialiser
- | DeclTag of declaration
- | StmtTag of statement
- | CaseLineTag of case_line
- | TopTag of top_level
- | IsoWhenTag of Ast.when_modifier
- | IsoWhenTTag of expression
- | IsoWhenFTag of expression
- | MetaPosTag of meta_pos
-
-let dotsExpr x = DotsExprTag x
-let dotsParam x = DotsParamTag x
-let dotsInit x = DotsInitTag x
-let dotsStmt x = DotsStmtTag x
-let dotsDecl x = DotsDeclTag x
-let dotsCase x = DotsCaseTag x
-let ident x = IdentTag x
-let expr x = ExprTag x
-let typeC x = TypeCTag x
-let param x = ParamTag x
-let ini x = InitTag x
-let decl x = DeclTag x
-let stmt x = StmtTag x
-let case_line x = CaseLineTag x
-let top x = TopTag x
-
-(* --------------------------------------------------------------------- *)
-(* Avoid cluttering the parser. Calculated in compute_lines.ml. *)
-
-let default_info _ = (* why is this a function? *)
- { line_start = -1; line_end = -1;
- logical_start = -1; logical_end = -1;
- attachable_start = true; attachable_end = true;
- mcode_start = []; mcode_end = [];
- column = -1; offset = -1; strings_before = []; strings_after = [] }
-
-let default_befaft _ =
- MIXED(ref (Ast.NOTHING,default_token_info,default_token_info))
-let context_befaft _ =
- CONTEXT(ref (Ast.NOTHING,default_token_info,default_token_info))
-
-let wrap x =
- { node = x;
- info = default_info();
- index = ref (-1);
- mcodekind = ref (default_befaft());
- exp_ty = ref None;
- bef_aft = NoDots;
- true_if_arg = false;
- true_if_test = false;
- true_if_test_exp = false;
- iso_info = [] }
-let context_wrap x =
- { node = x;
- info = default_info();
- index = ref (-1);
- mcodekind = ref (context_befaft());
- exp_ty = ref None;
- bef_aft = NoDots;
- true_if_arg = false;
- true_if_test = false;
- true_if_test_exp = false;
- iso_info = [] }
-let unwrap x = x.node
-let unwrap_mcode (x,_,_,_,_) = x
-let rewrap model x = { model with node = x }
-let rewrap_mcode (_,arity,info,mcodekind,pos) x = (x,arity,info,mcodekind,pos)
-let copywrap model x =
- { model with node = x; index = ref !(model.index);
- mcodekind = ref !(model.mcodekind); exp_ty = ref !(model.exp_ty)}
-let get_pos (_,_,_,_,x) = !x
-let get_pos_ref (_,_,_,_,x) = x
-let set_pos pos (m,arity,info,mcodekind,_) = (m,arity,info,mcodekind,ref pos)
-let get_info x = x.info
-let set_info x info = {x with info = info}
-let get_line x = x.info.line_start
-let get_line_end x = x.info.line_end
-let get_index x = !(x.index)
-let set_index x i = x.index := i
-let get_mcodekind x = !(x.mcodekind)
-let get_mcode_mcodekind (_,_,_,mcodekind,_) = mcodekind
-let get_mcodekind_ref x = x.mcodekind
-let set_mcodekind x mk = x.mcodekind := mk
-let set_type x t = x.exp_ty := t
-let get_type x = !(x.exp_ty)
-let get_dots_bef_aft x = x.bef_aft
-let set_dots_bef_aft x dots_bef_aft = {x with bef_aft = dots_bef_aft}
-let get_arg_exp x = x.true_if_arg
-let set_arg_exp x = {x with true_if_arg = true}
-let get_test_pos x = x.true_if_test
-let set_test_pos x = {x with true_if_test = true}
-let get_test_exp x = x.true_if_test_exp
-let set_test_exp x = {x with true_if_test_exp = true}
-let get_iso x = x.iso_info
-let set_iso x i = if !Flag.track_iso_usage then {x with iso_info = i} else x
-let set_mcode_data data (_,ar,info,mc,pos) = (data,ar,info,mc,pos)
-
-(* --------------------------------------------------------------------- *)
-
-(* unique indices, for mcode and tree nodes *)
-let index_counter = ref 0
-let fresh_index _ = let cur = !index_counter in index_counter := cur + 1; cur
-
-(* --------------------------------------------------------------------- *)
-
-let undots d =
- match unwrap d with
- | DOTS e -> e
- | CIRCLES e -> e
- | STARS e -> e
-
-(* --------------------------------------------------------------------- *)
-
-let rec ast0_type_to_type ty =
- match unwrap ty with
- ConstVol(cv,ty) -> Type_cocci.ConstVol(const_vol cv,ast0_type_to_type ty)
- | BaseType(bty,strings) ->
- Type_cocci.BaseType(baseType bty)
- | Signed(sgn,None) ->
- Type_cocci.SignedT(sign sgn,None)
- | Signed(sgn,Some ty) ->
- let bty = ast0_type_to_type ty in
- Type_cocci.SignedT(sign sgn,Some bty)
- | Pointer(ty,_) -> Type_cocci.Pointer(ast0_type_to_type ty)
- | FunctionPointer(ty,_,_,_,_,params,_) ->
- Type_cocci.FunctionPointer(ast0_type_to_type ty)
- | FunctionType _ -> failwith "not supported"
- | Array(ety,_,_,_) -> Type_cocci.Array(ast0_type_to_type ety)
- | EnumName(su,tag) ->
- (match unwrap tag with
- Id(tag) ->
- Type_cocci.EnumName(false,unwrap_mcode tag)
- | MetaId(tag,_,_) ->
- (Printf.printf
- "warning: enum with a metavariable name detected.\n";
- Printf.printf
- "For type checking assuming the name of the metavariable is the name of the type\n";
- let (rule,tag) = unwrap_mcode tag in
- Type_cocci.EnumName(true,rule^tag))
- | _ -> failwith "unexpected enum type name")
- | StructUnionName(su,Some tag) ->
- (match unwrap tag with
- Id(tag) ->
- Type_cocci.StructUnionName(structUnion su,false,unwrap_mcode tag)
- | MetaId(tag,_,_) ->
- (Printf.printf
- "warning: struct/union with a metavariable name detected.\n";
- Printf.printf
- "For type checking assuming the name of the metavariable is the name of the type\n";
- let (rule,tag) = unwrap_mcode tag in
- Type_cocci.StructUnionName(structUnion su,true,rule^tag))
- | _ -> failwith "unexpected struct/union type name")
- | StructUnionName(su,None) -> failwith "nameless structure - what to do???"
- | StructUnionDef(ty,_,_,_) -> ast0_type_to_type ty
- | TypeName(name) -> Type_cocci.TypeName(unwrap_mcode name)
- | MetaType(name,_) ->
- Type_cocci.MetaType(unwrap_mcode name,Type_cocci.Unitary,false)
- | DisjType(_,types,_,_) -> failwith "unexpected DisjType"
- | OptType(ty) | UniqueType(ty) ->
- ast0_type_to_type ty
-
-and baseType = function
- Ast.VoidType -> Type_cocci.VoidType
- | Ast.CharType -> Type_cocci.CharType
- | Ast.ShortType -> Type_cocci.ShortType
- | Ast.IntType -> Type_cocci.IntType
- | Ast.DoubleType -> Type_cocci.DoubleType
- | Ast.FloatType -> Type_cocci.FloatType
- | Ast.LongType -> Type_cocci.LongType
- | Ast.LongLongType -> Type_cocci.LongLongType
-
-and structUnion t =
- match unwrap_mcode t with
- Ast.Struct -> Type_cocci.Struct
- | Ast.Union -> Type_cocci.Union
-
-and sign t =
- match unwrap_mcode t with
- Ast.Signed -> Type_cocci.Signed
- | Ast.Unsigned -> Type_cocci.Unsigned
-
-and const_vol t =
- match unwrap_mcode t with
- Ast.Const -> Type_cocci.Const
- | Ast.Volatile -> Type_cocci.Volatile
-
-(* --------------------------------------------------------------------- *)
-(* this function is a rather minimal attempt. the problem is that information
-has been lost. but since it is only used for metavariable types in the isos,
-perhaps it doesn't matter *)
-and make_mcode x = (x,NONE,default_info(),context_befaft(),ref NoMetaPos)
-let make_mcode_info x info = (x,NONE,info,context_befaft(),ref NoMetaPos)
-
-exception TyConv
-
-let rec reverse_type ty =
- match ty with
- Type_cocci.ConstVol(cv,ty) ->
- ConstVol(reverse_const_vol cv,context_wrap(reverse_type ty))
- | Type_cocci.BaseType(bty) ->
- BaseType(reverse_baseType bty,[(* not used *)])
- | Type_cocci.SignedT(sgn,None) -> Signed(reverse_sign sgn,None)
- | Type_cocci.SignedT(sgn,Some bty) ->
- Signed(reverse_sign sgn,Some (context_wrap(reverse_type ty)))
- | Type_cocci.Pointer(ty) ->
- Pointer(context_wrap(reverse_type ty),make_mcode "*")
- | Type_cocci.EnumName(mv,tag) ->
- if mv
- then
- (* not right... *)
- EnumName
- (make_mcode "enum",
- context_wrap(MetaId(make_mcode ("",tag),[],Impure)))
- else
- EnumName(make_mcode "enum",context_wrap(Id(make_mcode tag)))
- | Type_cocci.StructUnionName(su,mv,tag) ->
- if mv
- then
- (* not right... *)
- StructUnionName
- (reverse_structUnion su,
- Some(context_wrap(MetaId(make_mcode ("",tag),[],Impure))))
- else
- StructUnionName
- (reverse_structUnion su,
- Some (context_wrap(Id(make_mcode tag))))
- | Type_cocci.TypeName(name) -> TypeName(make_mcode name)
- | Type_cocci.MetaType(name,_,_) ->
- MetaType(make_mcode name,Impure(*not really right*))
- | _ -> raise TyConv
-
-and reverse_baseType = function
- Type_cocci.VoidType -> Ast.VoidType
- | Type_cocci.CharType -> Ast.CharType
- | Type_cocci.BoolType -> Ast.IntType
- | Type_cocci.ShortType -> Ast.ShortType
- | Type_cocci.IntType -> Ast.IntType
- | Type_cocci.DoubleType -> Ast.DoubleType
- | Type_cocci.FloatType -> Ast.FloatType
- | Type_cocci.LongType -> Ast.LongType
- | Type_cocci.LongLongType -> Ast.LongLongType
-
-and reverse_structUnion t =
- make_mcode
- (match t with
- Type_cocci.Struct -> Ast.Struct
- | Type_cocci.Union -> Ast.Union)
-
-and reverse_sign t =
- make_mcode
- (match t with
- Type_cocci.Signed -> Ast.Signed
- | Type_cocci.Unsigned -> Ast.Unsigned)
-
-and reverse_const_vol t =
- make_mcode
- (match t with
- Type_cocci.Const -> Ast.Const
- | Type_cocci.Volatile -> Ast.Volatile)
-
-(* --------------------------------------------------------------------- *)
-
-let lub_pure x y =
- match (x,y) with
- (Impure,_) | (_,Impure) -> Impure
- | (Pure,Context) | (Context,Pure) -> Impure
- | (Pure,_) | (_,Pure) -> Pure
- | (_,Context) | (Context,_) -> Context
- | _ -> PureContext
-
-(* --------------------------------------------------------------------- *)
-
-let rule_name = ref "" (* for the convenience of the parser *)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Arities matter for the minus slice, but not for the plus slice. *)
-
-(* + only allowed on code in a nest (in_nest = true). ? only allowed on
-rule_elems, and on subterms if the context is ? also. *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module V0 = Visitor_ast0
-module V = Visitor_ast
-
-let unitary = Type_cocci.Unitary
-
-let ctr = ref 0
-let get_ctr _ =
- let c = !ctr in
- ctr := !ctr + 1;
- c
-
-(* --------------------------------------------------------------------- *)
-(* Move plus tokens from the MINUS and CONTEXT structured nodes to the
-corresponding leftmost and rightmost mcodes *)
-
-let inline_mcodes =
- let bind x y = () in
- let option_default = () in
- let mcode _ = () in
- let do_nothing r k e =
- k e;
- let einfo = Ast0.get_info e in
- match (Ast0.get_mcodekind e) with
- Ast0.MINUS(replacements) ->
- (match !replacements with
- ([],_) -> ()
- | replacements ->
- let minus_try = function
- (true,mc) ->
- if List.for_all
- (function
- Ast0.MINUS(mreplacements) -> true | _ -> false)
- mc
- then
- (List.iter
- (function
- Ast0.MINUS(mreplacements) ->
- mreplacements := replacements
- | _ -> ())
- mc;
- true)
- else false
- | _ -> false in
- if not (minus_try(einfo.Ast0.attachable_start,
- einfo.Ast0.mcode_start)
- or
- minus_try(einfo.Ast0.attachable_end,
- einfo.Ast0.mcode_end))
- then
- failwith "minus tree should not have bad code on both sides")
- | Ast0.CONTEXT(befaft)
- | Ast0.MIXED(befaft) ->
- let concat starter startinfo ender endinfo =
- let lst =
- match (starter,ender) with
- ([],_) -> ender
- | (_,[]) -> starter
- | _ ->
- if startinfo.Ast0.tline_end = endinfo.Ast0.tline_start
- then (* put them in the same inner list *)
- let last = List.hd (List.rev starter) in
- let butlast = List.rev(List.tl(List.rev starter)) in
- butlast @ (last@(List.hd ender)) :: (List.tl ender)
- else starter @ ender in
- (lst,
- {endinfo with Ast0.tline_start = startinfo.Ast0.tline_start}) in
- let attach_bef bef beforeinfo = function
- (true,mcl) ->
- List.iter
- (function
- Ast0.MINUS(mreplacements) ->
- let (mrepl,tokeninfo) = !mreplacements in
- mreplacements := concat bef beforeinfo mrepl tokeninfo
- | Ast0.CONTEXT(mbefaft) ->
- (match !mbefaft with
- (Ast.BEFORE(mbef),mbeforeinfo,a) ->
- let (newbef,newinfo) =
- concat bef beforeinfo mbef mbeforeinfo in
- mbefaft := (Ast.BEFORE(newbef),newinfo,a)
- | (Ast.AFTER(maft),_,a) ->
- mbefaft :=
- (Ast.BEFOREAFTER(bef,maft),beforeinfo,a)
- | (Ast.BEFOREAFTER(mbef,maft),mbeforeinfo,a) ->
- let (newbef,newinfo) =
- concat bef beforeinfo mbef mbeforeinfo in
- mbefaft :=
- (Ast.BEFOREAFTER(newbef,maft),newinfo,a)
- | (Ast.NOTHING,_,a) ->
- mbefaft := (Ast.BEFORE(bef),beforeinfo,a))
- | _ -> failwith "unexpected annotation")
- mcl
- | _ ->
- failwith
- "context tree should not have bad code on both sides" in
- let attach_aft aft afterinfo = function
- (true,mcl) ->
- List.iter
- (function
- Ast0.MINUS(mreplacements) ->
- let (mrepl,tokeninfo) = !mreplacements in
- mreplacements := concat mrepl tokeninfo aft afterinfo
- | Ast0.CONTEXT(mbefaft) ->
- (match !mbefaft with
- (Ast.BEFORE(mbef),b,_) ->
- mbefaft :=
- (Ast.BEFOREAFTER(mbef,aft),b,afterinfo)
- | (Ast.AFTER(maft),b,mafterinfo) ->
- let (newaft,newinfo) =
- concat maft mafterinfo aft afterinfo in
- mbefaft := (Ast.AFTER(newaft),b,newinfo)
- | (Ast.BEFOREAFTER(mbef,maft),b,mafterinfo) ->
- let (newaft,newinfo) =
- concat maft mafterinfo aft afterinfo in
- mbefaft :=
- (Ast.BEFOREAFTER(mbef,newaft),b,newinfo)
- | (Ast.NOTHING,b,_) ->
- mbefaft := (Ast.AFTER(aft),b,afterinfo))
- | _ -> failwith "unexpected annotation")
- mcl
- | _ ->
- failwith
- "context tree should not have bad code on both sides" in
- (match !befaft with
- (Ast.BEFORE(bef),beforeinfo,_) ->
- attach_bef bef beforeinfo
- (einfo.Ast0.attachable_start,einfo.Ast0.mcode_start)
- | (Ast.AFTER(aft),_,afterinfo) ->
- attach_aft aft afterinfo
- (einfo.Ast0.attachable_end,einfo.Ast0.mcode_end)
- | (Ast.BEFOREAFTER(bef,aft),beforeinfo,afterinfo) ->
- attach_bef bef beforeinfo
- (einfo.Ast0.attachable_start,einfo.Ast0.mcode_start);
- attach_aft aft afterinfo
- (einfo.Ast0.attachable_end,einfo.Ast0.mcode_end)
- | (Ast.NOTHING,_,_) -> ())
- | Ast0.PLUS -> () in
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode mcode
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing
-
-(* --------------------------------------------------------------------- *)
-(* For function declarations. Can't use the mcode at the root, because that
-might be mixed when the function contains ()s, where agglomeration of -s is
-not possible. *)
-
-let check_allminus =
- let donothing r k e = k e in
- let bind x y = x && y in
- let option_default = true in
- let mcode (_,_,_,mc,_) =
- match mc with
- Ast0.MINUS(r) -> let (plusses,_) = !r in plusses = []
- | _ -> false in
-
- (* special case for disj *)
- let expression r k e =
- match Ast0.unwrap e with
- Ast0.DisjExpr(starter,expr_list,mids,ender) ->
- List.for_all r.V0.combiner_expression expr_list
- | _ -> k e in
-
- let declaration r k e =
- match Ast0.unwrap e with
- Ast0.DisjDecl(starter,decls,mids,ender) ->
- List.for_all r.V0.combiner_declaration decls
- | _ -> k e in
-
- let typeC r k e =
- match Ast0.unwrap e with
- Ast0.DisjType(starter,decls,mids,ender) ->
- List.for_all r.V0.combiner_typeC decls
- | _ -> k e in
-
- let statement r k e =
- match Ast0.unwrap e with
- Ast0.Disj(starter,statement_dots_list,mids,ender) ->
- List.for_all r.V0.combiner_statement_dots statement_dots_list
- | _ -> k e in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing expression typeC donothing donothing declaration
- statement donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Mcode *)
-
-let convert_info info =
- { Ast.line = info.Ast0.line_start; Ast.column = info.Ast0.column;
- Ast.strbef = info.Ast0.strings_before;
- Ast.straft = info.Ast0.strings_after; }
-
-let convert_mcodekind = function
- Ast0.MINUS(replacements) ->
- let (replacements,_) = !replacements in
- Ast.MINUS(Ast.NoPos,replacements)
- | Ast0.PLUS -> Ast.PLUS
- | Ast0.CONTEXT(befaft) ->
- let (befaft,_,_) = !befaft in Ast.CONTEXT(Ast.NoPos,befaft)
- | Ast0.MIXED(_) -> failwith "not possible for mcode"
-
-let pos_mcode(term,_,info,mcodekind,pos) =
- (* avoids a recursion problem *)
- (term,convert_info info,convert_mcodekind mcodekind,Ast.NoMetaPos)
-
-let mcode(term,_,info,mcodekind,pos) =
- let pos =
- match !pos with
- Ast0.MetaPos(pos,constraints,per) ->
- Ast.MetaPos(pos_mcode pos,constraints,per,unitary,false)
- | _ -> Ast.NoMetaPos in
- (term,convert_info info,convert_mcodekind mcodekind,pos)
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-let wrap ast line isos =
- {(Ast.make_term ast) with Ast.node_line = line;
- Ast.iso_info = isos}
-
-let rewrap ast0 isos ast =
- wrap ast ((Ast0.get_info ast0).Ast0.line_start) isos
-
-let no_isos = []
-
-(* no isos on tokens *)
-let tokenwrap (_,info,_,_) s ast = wrap ast info.Ast.line no_isos
-let iso_tokenwrap (_,info,_,_) s ast iso = wrap ast info.Ast.line iso
-
-let dots fn d =
- rewrap d no_isos
- (match Ast0.unwrap d with
- Ast0.DOTS(x) -> Ast.DOTS(List.map fn x)
- | Ast0.CIRCLES(x) -> Ast.CIRCLES(List.map fn x)
- | Ast0.STARS(x) -> Ast.STARS(List.map fn x))
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec do_isos l = List.map (function (nm,x) -> (nm,anything x)) l
-
-and ident i =
- rewrap i (do_isos (Ast0.get_iso i))
- (match Ast0.unwrap i with
- Ast0.Id(name) -> Ast.Id(mcode name)
- | Ast0.MetaId(name,constraints,_) ->
- let constraints = List.map ident constraints in
- Ast.MetaId(mcode name,constraints,unitary,false)
- | Ast0.MetaFunc(name,constraints,_) ->
- let constraints = List.map ident constraints in
- Ast.MetaFunc(mcode name,constraints,unitary,false)
- | Ast0.MetaLocalFunc(name,constraints,_) ->
- let constraints = List.map ident constraints in
- Ast.MetaLocalFunc(mcode name,constraints,unitary,false)
- | Ast0.OptIdent(id) -> Ast.OptIdent(ident id)
- | Ast0.UniqueIdent(id) -> Ast.UniqueIdent(ident id))
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-and expression e =
- let e1 =
- rewrap e (do_isos (Ast0.get_iso e))
- (match Ast0.unwrap e with
- Ast0.Ident(id) -> Ast.Ident(ident id)
- | Ast0.Constant(const) ->
- Ast.Constant(mcode const)
- | Ast0.FunCall(fn,lp,args,rp) ->
- let fn = expression fn in
- let lp = mcode lp in
- let args = dots expression args in
- let rp = mcode rp in
- Ast.FunCall(fn,lp,args,rp)
- | Ast0.Assignment(left,op,right,simple) ->
- Ast.Assignment(expression left,mcode op,expression right,simple)
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- let exp1 = expression exp1 in
- let why = mcode why in
- let exp2 = get_option expression exp2 in
- let colon = mcode colon in
- let exp3 = expression exp3 in
- Ast.CondExpr(exp1,why,exp2,colon,exp3)
- | Ast0.Postfix(exp,op) ->
- Ast.Postfix(expression exp,mcode op)
- | Ast0.Infix(exp,op) ->
- Ast.Infix(expression exp,mcode op)
- | Ast0.Unary(exp,op) ->
- Ast.Unary(expression exp,mcode op)
- | Ast0.Binary(left,op,right) ->
- Ast.Binary(expression left,mcode op,expression right)
- | Ast0.Nested(left,op,right) ->
- Ast.Nested(expression left,mcode op,expression right)
- | Ast0.Paren(lp,exp,rp) ->
- Ast.Paren(mcode lp,expression exp,mcode rp)
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- Ast.ArrayAccess(expression exp1,mcode lb,expression exp2,mcode rb)
- | Ast0.RecordAccess(exp,pt,field) ->
- Ast.RecordAccess(expression exp,mcode pt,ident field)
- | Ast0.RecordPtAccess(exp,ar,field) ->
- Ast.RecordPtAccess(expression exp,mcode ar,ident field)
- | Ast0.Cast(lp,ty,rp,exp) ->
- Ast.Cast(mcode lp,typeC ty,mcode rp,expression exp)
- | Ast0.SizeOfExpr(szf,exp) ->
- Ast.SizeOfExpr(mcode szf,expression exp)
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- Ast.SizeOfType(mcode szf, mcode lp,typeC ty,mcode rp)
- | Ast0.TypeExp(ty) -> Ast.TypeExp(typeC ty)
- | Ast0.MetaErr(name,constraints,_) ->
- let constraints = List.map expression constraints in
- Ast.MetaErr(mcode name,constraints,unitary,false)
- | Ast0.MetaExpr(name,constraints,ty,form,_) ->
- let constraints = List.map expression constraints in
- Ast.MetaExpr(mcode name,constraints,unitary,ty,form,false)
- | Ast0.MetaExprList(name,Some lenname,_) ->
- Ast.MetaExprList(mcode name,Some (mcode lenname,unitary,false),
- unitary,false)
- | Ast0.MetaExprList(name,None,_) ->
- Ast.MetaExprList(mcode name,None,unitary,false)
- | Ast0.EComma(cm) -> Ast.EComma(mcode cm)
- | Ast0.DisjExpr(_,exps,_,_) -> Ast.DisjExpr(List.map expression exps)
- | Ast0.NestExpr(_,exp_dots,_,whencode,multi) ->
- let whencode = get_option expression whencode in
- Ast.NestExpr(dots expression exp_dots,whencode,multi)
- | Ast0.Edots(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option expression whencode in
- Ast.Edots(dots,whencode)
- | Ast0.Ecircles(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option expression whencode in
- Ast.Ecircles(dots,whencode)
- | Ast0.Estars(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option expression whencode in
- Ast.Estars(dots,whencode)
- | Ast0.OptExp(exp) -> Ast.OptExp(expression exp)
- | Ast0.UniqueExp(exp) -> Ast.UniqueExp(expression exp)) in
- if Ast0.get_test_exp e then Ast.set_test_exp e1 else e1
-
-and expression_dots ed = dots expression ed
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and rewrap_iso t t1 = rewrap t (do_isos (Ast0.get_iso t)) t1
-
-and typeC t =
- rewrap t (do_isos (Ast0.get_iso t))
- (match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) ->
- let rec collect_disjs t =
- match Ast0.unwrap t with
- Ast0.DisjType(_,types,_,_) ->
- if Ast0.get_iso t = []
- then List.concat (List.map collect_disjs types)
- else failwith "unexpected iso on a disjtype"
- | _ -> [t] in
- let res =
- List.map
- (function ty ->
- Ast.Type
- (Some (mcode cv),rewrap_iso ty (base_typeC ty)))
- (collect_disjs ty) in
- (* one could worry that isos are lost because we flatten the
- disjunctions. but there should not be isos on the disjunctions
- themselves. *)
- (match res with
- [ty] -> ty
- | types -> Ast.DisjType(List.map (rewrap t no_isos) types))
- | Ast0.BaseType(_) | Ast0.Signed(_,_) | Ast0.Pointer(_,_)
- | Ast0.FunctionPointer(_,_,_,_,_,_,_) | Ast0.FunctionType(_,_,_,_)
- | Ast0.Array(_,_,_,_) | Ast0.EnumName(_,_) | Ast0.StructUnionName(_,_)
- | Ast0.StructUnionDef(_,_,_,_) | Ast0.TypeName(_) | Ast0.MetaType(_,_) ->
- Ast.Type(None,rewrap t no_isos (base_typeC t))
- | Ast0.DisjType(_,types,_,_) -> Ast.DisjType(List.map typeC types)
- | Ast0.OptType(ty) -> Ast.OptType(typeC ty)
- | Ast0.UniqueType(ty) -> Ast.UniqueType(typeC ty))
-
-and base_typeC t =
- match Ast0.unwrap t with
- Ast0.BaseType(ty,strings) -> Ast.BaseType(ty,List.map mcode strings)
- | Ast0.Signed(sgn,ty) ->
- Ast.SignedT(mcode sgn,
- get_option (function x -> rewrap_iso x (base_typeC x)) ty)
- | Ast0.Pointer(ty,star) -> Ast.Pointer(typeC ty,mcode star)
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- Ast.FunctionPointer
- (typeC ty,mcode lp1,mcode star,mcode rp1,
- mcode lp2,parameter_list params,mcode rp2)
- | Ast0.FunctionType(ret,lp,params,rp) ->
- let allminus = check_allminus.V0.combiner_typeC t in
- Ast.FunctionType
- (allminus,get_option typeC ret,mcode lp,
- parameter_list params,mcode rp)
- | Ast0.Array(ty,lb,size,rb) ->
- Ast.Array(typeC ty,mcode lb,get_option expression size,mcode rb)
- | Ast0.EnumName(kind,name) ->
- Ast.EnumName(mcode kind,ident name)
- | Ast0.StructUnionName(kind,name) ->
- Ast.StructUnionName(mcode kind,get_option ident name)
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- Ast.StructUnionDef(typeC ty,mcode lb,
- dots declaration decls,
- mcode rb)
- | Ast0.TypeName(name) -> Ast.TypeName(mcode name)
- | Ast0.MetaType(name,_) ->
- Ast.MetaType(mcode name,unitary,false)
- | _ -> failwith "ast0toast: unexpected type"
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and declaration d =
- rewrap d (do_isos (Ast0.get_iso d))
- (match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- let stg = get_option mcode stg in
- let ty = typeC ty in
- let id = ident id in
- let eq = mcode eq in
- let ini = initialiser ini in
- let sem = mcode sem in
- Ast.Init(stg,ty,id,eq,ini,sem)
- | Ast0.UnInit(stg,ty,id,sem) ->
- (match Ast0.unwrap ty with
- Ast0.FunctionType(tyx,lp1,params,rp1) ->
- let allminus = check_allminus.V0.combiner_declaration d in
- Ast.UnInit(get_option mcode stg,
- rewrap ty (do_isos (Ast0.get_iso ty))
- (Ast.Type
- (None,
- rewrap ty no_isos
- (Ast.FunctionType
- (allminus,get_option typeC tyx,mcode lp1,
- parameter_list params,mcode rp1)))),
- ident id,mcode sem)
- | _ -> Ast.UnInit(get_option mcode stg,typeC ty,ident id,mcode sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- let name = ident name in
- let lp = mcode lp in
- let args = dots expression args in
- let rp = mcode rp in
- let sem = mcode sem in
- Ast.MacroDecl(name,lp,args,rp,sem)
- | Ast0.TyDecl(ty,sem) -> Ast.TyDecl(typeC ty,mcode sem)
- | Ast0.Typedef(stg,ty,id,sem) ->
- let id = typeC id in
- (match Ast.unwrap id with
- Ast.Type(None,id) -> (* only MetaType or Id *)
- Ast.Typedef(mcode stg,typeC ty,id,mcode sem)
- | _ -> failwith "bad typedef")
- | Ast0.DisjDecl(_,decls,_,_) -> Ast.DisjDecl(List.map declaration decls)
- | Ast0.Ddots(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option declaration whencode in
- Ast.Ddots(dots,whencode)
- | Ast0.OptDecl(decl) -> Ast.OptDecl(declaration decl)
- | Ast0.UniqueDecl(decl) -> Ast.UniqueDecl(declaration decl))
-
-and declaration_dots l = dots declaration l
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and strip_idots initlist =
- match Ast0.unwrap initlist with
- Ast0.DOTS(x) ->
- let (whencode,init) =
- List.fold_left
- (function (prevwhen,previnit) ->
- function cur ->
- match Ast0.unwrap cur with
- Ast0.Idots(dots,Some whencode) ->
- (whencode :: prevwhen, previnit)
- | Ast0.Idots(dots,None) -> (prevwhen,previnit)
- | _ -> (prevwhen, cur :: previnit))
- ([],[]) x in
- (List.rev whencode, List.rev init)
- | Ast0.CIRCLES(x) | Ast0.STARS(x) -> failwith "not possible for an initlist"
-
-and initialiser i =
- rewrap i no_isos
- (match Ast0.unwrap i with
- Ast0.InitExpr(exp) -> Ast.InitExpr(expression exp)
- | Ast0.InitList(lb,initlist,rb) ->
- let (whencode,initlist) = strip_idots initlist in
- Ast.InitList(mcode lb,List.map initialiser initlist,mcode rb,
- List.map initialiser whencode)
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- Ast.InitGccDotName(mcode dot,ident name,mcode eq,initialiser ini)
- | Ast0.InitGccName(name,eq,ini) ->
- Ast.InitGccName(ident name,mcode eq,initialiser ini)
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- Ast.InitGccIndex(mcode lb,expression exp,mcode rb,mcode eq,
- initialiser ini)
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- Ast.InitGccRange(mcode lb,expression exp1,mcode dots,
- expression exp2,mcode rb,mcode eq,initialiser ini)
- | Ast0.IComma(comma) -> Ast.IComma(mcode comma)
- | Ast0.Idots(_,_) -> failwith "Idots should have been removed"
- | Ast0.OptIni(ini) -> Ast.OptIni(initialiser ini)
- | Ast0.UniqueIni(ini) -> Ast.UniqueIni(initialiser ini))
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef p =
- rewrap p no_isos
- (match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> Ast.VoidParam(typeC ty)
- | Ast0.Param(ty,id) -> Ast.Param(typeC ty,get_option ident id)
- | Ast0.MetaParam(name,_) ->
- Ast.MetaParam(mcode name,unitary,false)
- | Ast0.MetaParamList(name,Some lenname,_) ->
- Ast.MetaParamList(mcode name,Some(mcode lenname,unitary,false),
- unitary,false)
- | Ast0.MetaParamList(name,None,_) ->
- Ast.MetaParamList(mcode name,None,unitary,false)
- | Ast0.PComma(cm) -> Ast.PComma(mcode cm)
- | Ast0.Pdots(dots) -> Ast.Pdots(mcode dots)
- | Ast0.Pcircles(dots) -> Ast.Pcircles(mcode dots)
- | Ast0.OptParam(param) -> Ast.OptParam(parameterTypeDef param)
- | Ast0.UniqueParam(param) -> Ast.UniqueParam(parameterTypeDef param))
-
-and parameter_list l = dots parameterTypeDef l
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and statement s =
- let rec statement seqible s =
- let rewrap_stmt ast0 ast =
- let befaft =
- match Ast0.get_dots_bef_aft s with
- Ast0.NoDots -> Ast.NoDots
- | Ast0.DroppingBetweenDots s ->
- Ast.DroppingBetweenDots (statement seqible s,get_ctr())
- | Ast0.AddingBetweenDots s ->
- Ast.AddingBetweenDots (statement seqible s,get_ctr()) in
- Ast.set_dots_bef_aft befaft (rewrap ast0 no_isos ast) in
- let rewrap_rule_elem ast0 ast =
- rewrap ast0 (do_isos (Ast0.get_iso ast0)) ast in
- rewrap_stmt s
- (match Ast0.unwrap s with
- Ast0.Decl((_,bef),decl) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.Decl(convert_mcodekind bef,
- check_allminus.V0.combiner_statement s,
- declaration decl)))
- | Ast0.Seq(lbrace,body,rbrace) ->
- let lbrace = mcode lbrace in
- let (decls,body) = separate_decls seqible body in
- let rbrace = mcode rbrace in
- Ast.Seq(iso_tokenwrap lbrace s (Ast.SeqStart(lbrace))
- (do_isos (Ast0.get_iso s)),
- decls,body,
- tokenwrap rbrace s (Ast.SeqEnd(rbrace)))
- | Ast0.ExprStatement(exp,sem) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.ExprStatement(expression exp,mcode sem)))
- | Ast0.IfThen(iff,lp,exp,rp,branch,(_,aft)) ->
- Ast.IfThen
- (rewrap_rule_elem s
- (Ast.IfHeader(mcode iff,mcode lp,expression exp,mcode rp)),
- statement Ast.NotSequencible branch,
- ([],[],[],convert_mcodekind aft))
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,(_,aft)) ->
- let els = mcode els in
- Ast.IfThenElse
- (rewrap_rule_elem s
- (Ast.IfHeader(mcode iff,mcode lp,expression exp,mcode rp)),
- statement Ast.NotSequencible branch1,
- tokenwrap els s (Ast.Else(els)),
- statement Ast.NotSequencible branch2,
- ([],[],[],convert_mcodekind aft))
- | Ast0.While(wh,lp,exp,rp,body,(_,aft)) ->
- Ast.While(rewrap_rule_elem s
- (Ast.WhileHeader
- (mcode wh,mcode lp,expression exp,mcode rp)),
- statement Ast.NotSequencible body,
- ([],[],[],convert_mcodekind aft))
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- let wh = mcode wh in
- Ast.Do(rewrap_rule_elem s (Ast.DoHeader(mcode d)),
- statement Ast.NotSequencible body,
- tokenwrap wh s
- (Ast.WhileTail(wh,mcode lp,expression exp,mcode rp,
- mcode sem)))
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,(_,aft)) ->
- let fr = mcode fr in
- let lp = mcode lp in
- let exp1 = get_option expression exp1 in
- let sem1 = mcode sem1 in
- let exp2 = get_option expression exp2 in
- let sem2= mcode sem2 in
- let exp3 = get_option expression exp3 in
- let rp = mcode rp in
- let body = statement Ast.NotSequencible body in
- Ast.For(rewrap_rule_elem s
- (Ast.ForHeader(fr,lp,exp1,sem1,exp2,sem2,exp3,rp)),
- body,([],[],[],convert_mcodekind aft))
- | Ast0.Iterator(nm,lp,args,rp,body,(_,aft)) ->
- Ast.Iterator(rewrap_rule_elem s
- (Ast.IteratorHeader
- (ident nm,mcode lp,
- dots expression args,
- mcode rp)),
- statement Ast.NotSequencible body,
- ([],[],[],convert_mcodekind aft))
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- let switch = mcode switch in
- let lp = mcode lp in
- let exp = expression exp in
- let rp = mcode rp in
- let lb = mcode lb in
- let cases = List.map case_line (Ast0.undots cases) in
- let rb = mcode rb in
- Ast.Switch(rewrap_rule_elem s (Ast.SwitchHeader(switch,lp,exp,rp)),
- tokenwrap lb s (Ast.SeqStart(lb)),
- cases,
- tokenwrap rb s (Ast.SeqEnd(rb)))
- | Ast0.Break(br,sem) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Break(mcode br,mcode sem)))
- | Ast0.Continue(cont,sem) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Continue(mcode cont,mcode sem)))
- | Ast0.Label(l,dd) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Label(ident l,mcode dd)))
- | Ast0.Goto(goto,l,sem) ->
- Ast.Atomic
- (rewrap_rule_elem s (Ast.Goto(mcode goto,ident l,mcode sem)))
- | Ast0.Return(ret,sem) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Return(mcode ret,mcode sem)))
- | Ast0.ReturnExpr(ret,exp,sem) ->
- Ast.Atomic
- (rewrap_rule_elem s
- (Ast.ReturnExpr(mcode ret,expression exp,mcode sem)))
- | Ast0.MetaStmt(name,_) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.MetaStmt(mcode name,unitary,seqible,false)))
- | Ast0.MetaStmtList(name,_) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.MetaStmtList(mcode name,unitary,false)))
- | Ast0.TopExp(exp) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.TopExp(expression exp)))
- | Ast0.Exp(exp) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Exp(expression exp)))
- | Ast0.TopInit(init) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.TopInit(initialiser init)))
- | Ast0.Ty(ty) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Ty(typeC ty)))
- | Ast0.Disj(_,rule_elem_dots_list,_,_) ->
- Ast.Disj(List.map (function x -> statement_dots seqible x)
- rule_elem_dots_list)
- | Ast0.Nest(_,rule_elem_dots,_,whn,multi) ->
- Ast.Nest
- (statement_dots Ast.Sequencible rule_elem_dots,
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn,
- multi,[],[])
- | Ast0.Dots(d,whn) ->
- let d = mcode d in
- let whn =
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn in
- Ast.Dots(d,whn,[],[])
- | Ast0.Circles(d,whn) ->
- let d = mcode d in
- let whn =
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn in
- Ast.Circles(d,whn,[],[])
- | Ast0.Stars(d,whn) ->
- let d = mcode d in
- let whn =
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn in
- Ast.Stars(d,whn,[],[])
- | Ast0.FunDecl((_,bef),fi,name,lp,params,rp,lbrace,body,rbrace) ->
- let fi = List.map fninfo fi in
- let name = ident name in
- let lp = mcode lp in
- let params = parameter_list params in
- let rp = mcode rp in
- let lbrace = mcode lbrace in
- let (decls,body) = separate_decls seqible body in
- let rbrace = mcode rbrace in
- let allminus = check_allminus.V0.combiner_statement s in
- Ast.FunDecl(rewrap_rule_elem s
- (Ast.FunHeader(convert_mcodekind bef,
- allminus,fi,name,lp,params,rp)),
- tokenwrap lbrace s (Ast.SeqStart(lbrace)),
- decls,body,
- tokenwrap rbrace s (Ast.SeqEnd(rbrace)))
- | Ast0.Include(inc,str) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Include(mcode inc,mcode str)))
- | Ast0.Define(def,id,params,body) ->
- Ast.Define
- (rewrap_rule_elem s
- (Ast.DefineHeader
- (mcode def,ident id, define_parameters params)),
- statement_dots Ast.NotSequencible (*not sure*) body)
- | Ast0.OptStm(stm) -> Ast.OptStm(statement seqible stm)
- | Ast0.UniqueStm(stm) -> Ast.UniqueStm(statement seqible stm))
-
- and define_parameters p =
- rewrap p no_isos
- (match Ast0.unwrap p with
- Ast0.NoParams -> Ast.NoParams
- | Ast0.DParams(lp,params,rp) ->
- Ast.DParams(mcode lp,
- dots define_param params,
- mcode rp))
-
- and define_param p =
- rewrap p no_isos
- (match Ast0.unwrap p with
- Ast0.DParam(id) -> Ast.DParam(ident id)
- | Ast0.DPComma(comma) -> Ast.DPComma(mcode comma)
- | Ast0.DPdots(d) -> Ast.DPdots(mcode d)
- | Ast0.DPcircles(c) -> Ast.DPcircles(mcode c)
- | Ast0.OptDParam(dp) -> Ast.OptDParam(define_param dp)
- | Ast0.UniqueDParam(dp) -> Ast.UniqueDParam(define_param dp))
-
- and whencode notfn alwaysfn = function
- Ast0.WhenNot a -> Ast.WhenNot (notfn a)
- | Ast0.WhenAlways a -> Ast.WhenAlways (alwaysfn a)
- | Ast0.WhenModifier(x) -> Ast.WhenModifier(x)
- | x ->
- let rewrap_rule_elem ast0 ast =
- rewrap ast0 (do_isos (Ast0.get_iso ast0)) ast in
- match x with
- Ast0.WhenNotTrue(e) ->
- Ast.WhenNotTrue(rewrap_rule_elem e (Ast.Exp(expression e)))
- | Ast0.WhenNotFalse(e) ->
- Ast.WhenNotFalse(rewrap_rule_elem e (Ast.Exp(expression e)))
- | _ -> failwith "not possible"
-
- and process_list seqible isos = function
- [] -> []
- | x::rest ->
- let first = statement seqible x in
- let first =
- if !Flag.track_iso_usage
- then Ast.set_isos first (isos@(Ast.get_isos first))
- else first in
- (match Ast0.unwrap x with
- Ast0.Dots(_,_) | Ast0.Nest(_) ->
- first::(process_list (Ast.SequencibleAfterDots []) no_isos rest)
- | _ ->
- first::(process_list Ast.Sequencible no_isos rest))
-
- and statement_dots seqible d =
- let isos = do_isos (Ast0.get_iso d) in
- rewrap d no_isos
- (match Ast0.unwrap d with
- Ast0.DOTS(x) -> Ast.DOTS(process_list seqible isos x)
- | Ast0.CIRCLES(x) -> Ast.CIRCLES(process_list seqible isos x)
- | Ast0.STARS(x) -> Ast.STARS(process_list seqible isos x))
-
- and separate_decls seqible d =
- let rec collect_decls = function
- [] -> ([],[])
- | (x::xs) as l ->
- (match Ast0.unwrap x with
- Ast0.Decl(_) ->
- let (decls,other) = collect_decls xs in
- (x :: decls,other)
- | Ast0.Dots(_,_) | Ast0.Nest(_,_,_,_,_) ->
- let (decls,other) = collect_decls xs in
- (match decls with
- [] -> ([],x::other)
- | _ -> (x :: decls,other))
- | Ast0.Disj(starter,stmt_dots_list,mids,ender) ->
- let disjs = List.map collect_dot_decls stmt_dots_list in
- let all_decls = List.for_all (function (_,s) -> s=[]) disjs in
- if all_decls
- then
- let (decls,other) = collect_decls xs in
- (x :: decls,other)
- else ([],l)
- | _ -> ([],l))
-
- and collect_dot_decls d =
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> collect_decls x
- | Ast0.CIRCLES(x) -> collect_decls x
- | Ast0.STARS(x) -> collect_decls x in
-
- let process l d fn =
- let (decls,other) = collect_decls l in
- (rewrap d no_isos (fn (List.map (statement seqible) decls)),
- rewrap d no_isos
- (fn (process_list seqible (do_isos (Ast0.get_iso d)) other))) in
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> process x d (function x -> Ast.DOTS x)
- | Ast0.CIRCLES(x) -> process x d (function x -> Ast.CIRCLES x)
- | Ast0.STARS(x) -> process x d (function x -> Ast.STARS x) in
-
- statement Ast.Sequencible s
-
-and fninfo = function
- Ast0.FStorage(stg) -> Ast.FStorage(mcode stg)
- | Ast0.FType(ty) -> Ast.FType(typeC ty)
- | Ast0.FInline(inline) -> Ast.FInline(mcode inline)
- | Ast0.FAttr(attr) -> Ast.FAttr(mcode attr)
-
-and option_to_list = function
- Some x -> [x]
- | None -> []
-
-and case_line c =
- rewrap c no_isos
- (match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- let def = mcode def in
- let colon = mcode colon in
- let code = dots statement code in
- Ast.CaseLine(rewrap c no_isos (Ast.Default(def,colon)),code)
- | Ast0.Case(case,exp,colon,code) ->
- let case = mcode case in
- let exp = expression exp in
- let colon = mcode colon in
- let code = dots statement code in
- Ast.CaseLine(rewrap c no_isos (Ast.Case(case,exp,colon)),code)
- | Ast0.OptCase(case) -> Ast.OptCase(case_line case))
-
-and statement_dots l = dots statement l
-
-(* --------------------------------------------------------------------- *)
-
-(* what is possible is only what is at the top level in an iso *)
-and anything = function
- Ast0.DotsExprTag(d) -> Ast.ExprDotsTag(expression_dots d)
- | Ast0.DotsParamTag(d) -> Ast.ParamDotsTag(parameter_list d)
- | Ast0.DotsInitTag(d) -> failwith "not possible"
- | Ast0.DotsStmtTag(d) -> Ast.StmtDotsTag(statement_dots d)
- | Ast0.DotsDeclTag(d) -> Ast.DeclDotsTag(declaration_dots d)
- | Ast0.DotsCaseTag(d) -> failwith "not possible"
- | Ast0.IdentTag(d) -> Ast.IdentTag(ident d)
- | Ast0.ExprTag(d) -> Ast.ExpressionTag(expression d)
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "only in isos, not converted to ast"
- | Ast0.TypeCTag(d) -> Ast.FullTypeTag(typeC d)
- | Ast0.ParamTag(d) -> Ast.ParamTag(parameterTypeDef d)
- | Ast0.InitTag(d) -> Ast.InitTag(initialiser d)
- | Ast0.DeclTag(d) -> Ast.DeclarationTag(declaration d)
- | Ast0.StmtTag(d) -> Ast.StatementTag(statement d)
- | Ast0.CaseLineTag(d) -> Ast.CaseLineTag(case_line d)
- | Ast0.TopTag(d) -> Ast.Code(top_level d)
- | Ast0.IsoWhenTag(_) -> failwith "not possible"
- | Ast0.IsoWhenTTag(_) -> failwith "not possible"
- | Ast0.IsoWhenFTag(_) -> failwith "not possible"
- | Ast0.MetaPosTag _ -> failwith "not possible"
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-(* top level isos are probably lost to tracking *)
-
-and top_level t =
- rewrap t no_isos
- (match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- Ast.FILEINFO(mcode old_file,mcode new_file)
- | Ast0.DECL(stmt) -> Ast.DECL(statement stmt)
- | Ast0.CODE(rule_elem_dots) ->
- Ast.CODE(statement_dots rule_elem_dots)
- | Ast0.ERRORWORDS(exps) -> Ast.ERRORWORDS(List.map expression exps)
- | Ast0.OTHER(_) -> failwith "eliminated by top_level")
-
-(* --------------------------------------------------------------------- *)
-(* Entry point for minus code *)
-
-(* Inline_mcodes is very important - sends + code attached to the - code
-down to the mcodes. The functions above can only be used when there is no
-attached + code, eg in + code itself. *)
-let ast0toast_toplevel x =
- inline_mcodes.V0.combiner_top_level x;
- top_level x
-
-let ast0toast name deps dropped exists x is_exp ruletype =
- List.iter inline_mcodes.V0.combiner_top_level x;
- Ast.CocciRule
- (name,(deps,dropped,exists),List.map top_level x,is_exp,ruletype)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Arities matter for the minus slice, but not for the plus slice. *)
-
-(* + only allowed on code in a nest (in_nest = true). ? only allowed on
-rule_elems, and on subterms if the context is ? also. *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module V0 = Visitor_ast0
-module V = Visitor_ast
-
-let unitary = Type_cocci.Unitary
-
-let ctr = ref 0
-let get_ctr _ =
- let c = !ctr in
- ctr := !ctr + 1;
- c
-
-(* --------------------------------------------------------------------- *)
-(* Move plus tokens from the MINUS and CONTEXT structured nodes to the
-corresponding leftmost and rightmost mcodes *)
-
-let inline_mcodes =
- let bind x y = () in
- let option_default = () in
- let mcode _ = () in
- let do_nothing r k e =
- k e;
- let einfo = Ast0.get_info e in
- match (Ast0.get_mcodekind e) with
- Ast0.MINUS(replacements) ->
- (match !replacements with
- ([],_) -> ()
- | replacements ->
- let minus_try = function
- (true,mc) ->
- if List.for_all
- (function
- Ast0.MINUS(mreplacements) -> true | _ -> false)
- mc
- then
- (List.iter
- (function
- Ast0.MINUS(mreplacements) ->
- mreplacements := replacements
- | _ -> ())
- mc;
- true)
- else false
- | _ -> false in
- if not (minus_try(einfo.Ast0.attachable_start,
- einfo.Ast0.mcode_start)
- or
- minus_try(einfo.Ast0.attachable_end,
- einfo.Ast0.mcode_end))
- then
- failwith "minus tree should not have bad code on both sides")
- | Ast0.CONTEXT(befaft)
- | Ast0.MIXED(befaft) ->
- let concat starter startinfo ender endinfo =
- let lst =
- match (starter,ender) with
- ([],_) -> ender
- | (_,[]) -> starter
- | _ ->
- if startinfo.Ast0.tline_end = endinfo.Ast0.tline_start
- then (* put them in the same inner list *)
- let last = List.hd (List.rev starter) in
- let butlast = List.rev(List.tl(List.rev starter)) in
- butlast @ (last@(List.hd ender)) :: (List.tl ender)
- else starter @ ender in
- (lst,
- {endinfo with Ast0.tline_start = startinfo.Ast0.tline_start}) in
- let attach_bef bef beforeinfo = function
- (true,mcl) ->
- List.iter
- (function
- Ast0.MINUS(mreplacements) ->
- let (mrepl,tokeninfo) = !mreplacements in
- mreplacements := concat bef beforeinfo mrepl tokeninfo
- | Ast0.CONTEXT(mbefaft) ->
- (match !mbefaft with
- (Ast.BEFORE(mbef),mbeforeinfo,a) ->
- let (newbef,newinfo) =
- concat bef beforeinfo mbef mbeforeinfo in
- mbefaft := (Ast.BEFORE(newbef),newinfo,a)
- | (Ast.AFTER(maft),_,a) ->
- mbefaft :=
- (Ast.BEFOREAFTER(bef,maft),beforeinfo,a)
- | (Ast.BEFOREAFTER(mbef,maft),mbeforeinfo,a) ->
- let (newbef,newinfo) =
- concat bef beforeinfo mbef mbeforeinfo in
- mbefaft :=
- (Ast.BEFOREAFTER(newbef,maft),newinfo,a)
- | (Ast.NOTHING,_,a) ->
- mbefaft := (Ast.BEFORE(bef),beforeinfo,a))
- | _ -> failwith "unexpected annotation")
- mcl
- | _ ->
- failwith
- "context tree should not have bad code on both sides" in
- let attach_aft aft afterinfo = function
- (true,mcl) ->
- List.iter
- (function
- Ast0.MINUS(mreplacements) ->
- let (mrepl,tokeninfo) = !mreplacements in
- mreplacements := concat mrepl tokeninfo aft afterinfo
- | Ast0.CONTEXT(mbefaft) ->
- (match !mbefaft with
- (Ast.BEFORE(mbef),b,_) ->
- mbefaft :=
- (Ast.BEFOREAFTER(mbef,aft),b,afterinfo)
- | (Ast.AFTER(maft),b,mafterinfo) ->
- let (newaft,newinfo) =
- concat maft mafterinfo aft afterinfo in
- mbefaft := (Ast.AFTER(newaft),b,newinfo)
- | (Ast.BEFOREAFTER(mbef,maft),b,mafterinfo) ->
- let (newaft,newinfo) =
- concat maft mafterinfo aft afterinfo in
- mbefaft :=
- (Ast.BEFOREAFTER(mbef,newaft),b,newinfo)
- | (Ast.NOTHING,b,_) ->
- mbefaft := (Ast.AFTER(aft),b,afterinfo))
- | _ -> failwith "unexpected annotation")
- mcl
- | _ ->
- failwith
- "context tree should not have bad code on both sides" in
- (match !befaft with
- (Ast.BEFORE(bef),beforeinfo,_) ->
- attach_bef bef beforeinfo
- (einfo.Ast0.attachable_start,einfo.Ast0.mcode_start)
- | (Ast.AFTER(aft),_,afterinfo) ->
- attach_aft aft afterinfo
- (einfo.Ast0.attachable_end,einfo.Ast0.mcode_end)
- | (Ast.BEFOREAFTER(bef,aft),beforeinfo,afterinfo) ->
- attach_bef bef beforeinfo
- (einfo.Ast0.attachable_start,einfo.Ast0.mcode_start);
- attach_aft aft afterinfo
- (einfo.Ast0.attachable_end,einfo.Ast0.mcode_end)
- | (Ast.NOTHING,_,_) -> ())
- | Ast0.PLUS -> () in
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode mcode
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing
-
-(* --------------------------------------------------------------------- *)
-(* For function declarations. Can't use the mcode at the root, because that
-might be mixed when the function contains ()s, where agglomeration of -s is
-not possible. *)
-
-let check_allminus =
- let donothing r k e = k e in
- let bind x y = x && y in
- let option_default = true in
- let mcode (_,_,_,mc,_) =
- match mc with
- Ast0.MINUS(r) -> let (plusses,_) = !r in plusses = []
- | _ -> false in
-
- (* special case for disj *)
- let expression r k e =
- match Ast0.unwrap e with
- Ast0.DisjExpr(starter,expr_list,mids,ender) ->
- List.for_all r.V0.combiner_expression expr_list
- | _ -> k e in
-
- let declaration r k e =
- match Ast0.unwrap e with
- Ast0.DisjDecl(starter,decls,mids,ender) ->
- List.for_all r.V0.combiner_declaration decls
- | _ -> k e in
-
- let typeC r k e =
- match Ast0.unwrap e with
- Ast0.DisjType(starter,decls,mids,ender) ->
- List.for_all r.V0.combiner_typeC decls
- | _ -> k e in
-
- let statement r k e =
- match Ast0.unwrap e with
- Ast0.Disj(starter,statement_dots_list,mids,ender) ->
- List.for_all r.V0.combiner_statement_dots statement_dots_list
- | _ -> k e in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing expression typeC donothing donothing declaration
- statement donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Mcode *)
-
-let convert_info info =
- { Ast.line = info.Ast0.line_start; Ast.column = info.Ast0.column;
- Ast.strbef = info.Ast0.strings_before;
- Ast.straft = info.Ast0.strings_after; }
-
-let convert_mcodekind = function
- Ast0.MINUS(replacements) ->
- let (replacements,_) = !replacements in
- Ast.MINUS(Ast.NoPos,replacements)
- | Ast0.PLUS -> Ast.PLUS
- | Ast0.CONTEXT(befaft) ->
- let (befaft,_,_) = !befaft in Ast.CONTEXT(Ast.NoPos,befaft)
- | Ast0.MIXED(_) -> failwith "not possible for mcode"
-
-let pos_mcode(term,_,info,mcodekind,pos) =
- (* avoids a recursion problem *)
- (term,convert_info info,convert_mcodekind mcodekind,Ast.NoMetaPos)
-
-let mcode(term,_,info,mcodekind,pos) =
- let pos =
- match !pos with
- Ast0.MetaPos(pos,constraints,per) ->
- Ast.MetaPos(pos_mcode pos,constraints,per,unitary,false)
- | _ -> Ast.NoMetaPos in
- (term,convert_info info,convert_mcodekind mcodekind,pos)
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-let wrap ast line isos =
- {(Ast.make_term ast) with Ast.node_line = line;
- Ast.iso_info = isos}
-
-let rewrap ast0 isos ast =
- wrap ast ((Ast0.get_info ast0).Ast0.line_start) isos
-
-let no_isos = []
-
-(* no isos on tokens *)
-let tokenwrap (_,info,_,_) s ast = wrap ast info.Ast.line no_isos
-let iso_tokenwrap (_,info,_,_) s ast iso = wrap ast info.Ast.line iso
-
-let dots fn d =
- rewrap d no_isos
- (match Ast0.unwrap d with
- Ast0.DOTS(x) -> Ast.DOTS(List.map fn x)
- | Ast0.CIRCLES(x) -> Ast.CIRCLES(List.map fn x)
- | Ast0.STARS(x) -> Ast.STARS(List.map fn x))
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec do_isos l = List.map (function (nm,x) -> (nm,anything x)) l
-
-and ident i =
- rewrap i (do_isos (Ast0.get_iso i))
- (match Ast0.unwrap i with
- Ast0.Id(name) -> Ast.Id(mcode name)
- | Ast0.MetaId(name,constraints,_) ->
- let constraints = List.map ident constraints in
- Ast.MetaId(mcode name,constraints,unitary,false)
- | Ast0.MetaFunc(name,constraints,_) ->
- let constraints = List.map ident constraints in
- Ast.MetaFunc(mcode name,constraints,unitary,false)
- | Ast0.MetaLocalFunc(name,constraints,_) ->
- let constraints = List.map ident constraints in
- Ast.MetaLocalFunc(mcode name,constraints,unitary,false)
- | Ast0.OptIdent(id) -> Ast.OptIdent(ident id)
- | Ast0.UniqueIdent(id) -> Ast.UniqueIdent(ident id))
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-and expression e =
- let e1 =
- rewrap e (do_isos (Ast0.get_iso e))
- (match Ast0.unwrap e with
- Ast0.Ident(id) -> Ast.Ident(ident id)
- | Ast0.Constant(const) ->
- Ast.Constant(mcode const)
- | Ast0.FunCall(fn,lp,args,rp) ->
- let fn = expression fn in
- let lp = mcode lp in
- let args = dots expression args in
- let rp = mcode rp in
- Ast.FunCall(fn,lp,args,rp)
- | Ast0.Assignment(left,op,right,simple) ->
- Ast.Assignment(expression left,mcode op,expression right,simple)
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- let exp1 = expression exp1 in
- let why = mcode why in
- let exp2 = get_option expression exp2 in
- let colon = mcode colon in
- let exp3 = expression exp3 in
- Ast.CondExpr(exp1,why,exp2,colon,exp3)
- | Ast0.Postfix(exp,op) ->
- Ast.Postfix(expression exp,mcode op)
- | Ast0.Infix(exp,op) ->
- Ast.Infix(expression exp,mcode op)
- | Ast0.Unary(exp,op) ->
- Ast.Unary(expression exp,mcode op)
- | Ast0.Binary(left,op,right) ->
- Ast.Binary(expression left,mcode op,expression right)
- | Ast0.Nested(left,op,right) ->
- Ast.Nested(expression left,mcode op,expression right)
- | Ast0.Paren(lp,exp,rp) ->
- Ast.Paren(mcode lp,expression exp,mcode rp)
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- Ast.ArrayAccess(expression exp1,mcode lb,expression exp2,mcode rb)
- | Ast0.RecordAccess(exp,pt,field) ->
- Ast.RecordAccess(expression exp,mcode pt,ident field)
- | Ast0.RecordPtAccess(exp,ar,field) ->
- Ast.RecordPtAccess(expression exp,mcode ar,ident field)
- | Ast0.Cast(lp,ty,rp,exp) ->
- Ast.Cast(mcode lp,typeC ty,mcode rp,expression exp)
- | Ast0.SizeOfExpr(szf,exp) ->
- Ast.SizeOfExpr(mcode szf,expression exp)
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- Ast.SizeOfType(mcode szf, mcode lp,typeC ty,mcode rp)
- | Ast0.TypeExp(ty) -> Ast.TypeExp(typeC ty)
- | Ast0.MetaErr(name,constraints,_) ->
- let constraints = List.map expression constraints in
- Ast.MetaErr(mcode name,constraints,unitary,false)
- | Ast0.MetaExpr(name,constraints,ty,form,_) ->
- let constraints = List.map expression constraints in
- Ast.MetaExpr(mcode name,constraints,unitary,ty,form,false)
- | Ast0.MetaExprList(name,Some lenname,_) ->
- Ast.MetaExprList(mcode name,Some (mcode lenname,unitary,false),
- unitary,false)
- | Ast0.MetaExprList(name,None,_) ->
- Ast.MetaExprList(mcode name,None,unitary,false)
- | Ast0.EComma(cm) -> Ast.EComma(mcode cm)
- | Ast0.DisjExpr(_,exps,_,_) -> Ast.DisjExpr(List.map expression exps)
- | Ast0.NestExpr(_,exp_dots,_,whencode,multi) ->
- let whencode = get_option expression whencode in
- Ast.NestExpr(dots expression exp_dots,whencode,multi)
- | Ast0.Edots(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option expression whencode in
- Ast.Edots(dots,whencode)
- | Ast0.Ecircles(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option expression whencode in
- Ast.Ecircles(dots,whencode)
- | Ast0.Estars(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option expression whencode in
- Ast.Estars(dots,whencode)
- | Ast0.OptExp(exp) -> Ast.OptExp(expression exp)
- | Ast0.UniqueExp(exp) -> Ast.UniqueExp(expression exp)) in
- if Ast0.get_test_exp e then Ast.set_test_exp e1 else e1
-
-and expression_dots ed = dots expression ed
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and rewrap_iso t t1 = rewrap t (do_isos (Ast0.get_iso t)) t1
-
-and typeC t =
- rewrap t (do_isos (Ast0.get_iso t))
- (match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) ->
- let rec collect_disjs t =
- match Ast0.unwrap t with
- Ast0.DisjType(_,types,_,_) ->
- if Ast0.get_iso t = []
- then List.concat (List.map collect_disjs types)
- else failwith "unexpected iso on a disjtype"
- | _ -> [t] in
- let res =
- List.map
- (function ty ->
- Ast.Type
- (Some (mcode cv),rewrap_iso ty (base_typeC ty)))
- (collect_disjs ty) in
- (* one could worry that isos are lost because we flatten the
- disjunctions. but there should not be isos on the disjunctions
- themselves. *)
- (match res with
- [ty] -> ty
- | types -> Ast.DisjType(List.map (rewrap t no_isos) types))
- | Ast0.BaseType(_) | Ast0.Signed(_,_) | Ast0.Pointer(_,_)
- | Ast0.FunctionPointer(_,_,_,_,_,_,_) | Ast0.FunctionType(_,_,_,_)
- | Ast0.Array(_,_,_,_) | Ast0.EnumName(_,_) | Ast0.StructUnionName(_,_)
- | Ast0.StructUnionDef(_,_,_,_) | Ast0.TypeName(_) | Ast0.MetaType(_,_) ->
- Ast.Type(None,rewrap t no_isos (base_typeC t))
- | Ast0.DisjType(_,types,_,_) -> Ast.DisjType(List.map typeC types)
- | Ast0.OptType(ty) -> Ast.OptType(typeC ty)
- | Ast0.UniqueType(ty) -> Ast.UniqueType(typeC ty))
-
-and base_typeC t =
- match Ast0.unwrap t with
- Ast0.BaseType(ty,strings) -> Ast.BaseType(ty,List.map mcode strings)
- | Ast0.Signed(sgn,ty) ->
- Ast.SignedT(mcode sgn,
- get_option (function x -> rewrap_iso x (base_typeC x)) ty)
- | Ast0.Pointer(ty,star) -> Ast.Pointer(typeC ty,mcode star)
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- Ast.FunctionPointer
- (typeC ty,mcode lp1,mcode star,mcode rp1,
- mcode lp2,parameter_list params,mcode rp2)
- | Ast0.FunctionType(ret,lp,params,rp) ->
- let allminus = check_allminus.V0.combiner_typeC t in
- Ast.FunctionType
- (allminus,get_option typeC ret,mcode lp,
- parameter_list params,mcode rp)
- | Ast0.Array(ty,lb,size,rb) ->
- Ast.Array(typeC ty,mcode lb,get_option expression size,mcode rb)
- | Ast0.EnumName(kind,name) ->
- Ast.EnumName(mcode kind,ident name)
- | Ast0.StructUnionName(kind,name) ->
- Ast.StructUnionName(mcode kind,get_option ident name)
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- Ast.StructUnionDef(typeC ty,mcode lb,
- dots declaration decls,
- mcode rb)
- | Ast0.TypeName(name) -> Ast.TypeName(mcode name)
- | Ast0.MetaType(name,_) ->
- Ast.MetaType(mcode name,unitary,false)
- | _ -> failwith "ast0toast: unexpected type"
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and declaration d =
- rewrap d (do_isos (Ast0.get_iso d))
- (match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- let stg = get_option mcode stg in
- let ty = typeC ty in
- let id = ident id in
- let eq = mcode eq in
- let ini = initialiser ini in
- let sem = mcode sem in
- Ast.Init(stg,ty,id,eq,ini,sem)
- | Ast0.UnInit(stg,ty,id,sem) ->
- (match Ast0.unwrap ty with
- Ast0.FunctionType(tyx,lp1,params,rp1) ->
- let allminus = check_allminus.V0.combiner_declaration d in
- Ast.UnInit(get_option mcode stg,
- rewrap ty (do_isos (Ast0.get_iso ty))
- (Ast.Type
- (None,
- rewrap ty no_isos
- (Ast.FunctionType
- (allminus,get_option typeC tyx,mcode lp1,
- parameter_list params,mcode rp1)))),
- ident id,mcode sem)
- | _ -> Ast.UnInit(get_option mcode stg,typeC ty,ident id,mcode sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- let name = ident name in
- let lp = mcode lp in
- let args = dots expression args in
- let rp = mcode rp in
- let sem = mcode sem in
- Ast.MacroDecl(name,lp,args,rp,sem)
- | Ast0.TyDecl(ty,sem) -> Ast.TyDecl(typeC ty,mcode sem)
- | Ast0.Typedef(stg,ty,id,sem) ->
- let id = typeC id in
- (match Ast.unwrap id with
- Ast.Type(None,id) -> (* only MetaType or Id *)
- Ast.Typedef(mcode stg,typeC ty,id,mcode sem)
- | _ -> failwith "bad typedef")
- | Ast0.DisjDecl(_,decls,_,_) -> Ast.DisjDecl(List.map declaration decls)
- | Ast0.Ddots(dots,whencode) ->
- let dots = mcode dots in
- let whencode = get_option declaration whencode in
- Ast.Ddots(dots,whencode)
- | Ast0.OptDecl(decl) -> Ast.OptDecl(declaration decl)
- | Ast0.UniqueDecl(decl) -> Ast.UniqueDecl(declaration decl))
-
-and declaration_dots l = dots declaration l
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and strip_idots initlist =
- match Ast0.unwrap initlist with
- Ast0.DOTS(x) ->
- let (whencode,init) =
- List.fold_left
- (function (prevwhen,previnit) ->
- function cur ->
- match Ast0.unwrap cur with
- Ast0.Idots(dots,Some whencode) ->
- (whencode :: prevwhen, previnit)
- | Ast0.Idots(dots,None) -> (prevwhen,previnit)
- | _ -> (prevwhen, cur :: previnit))
- ([],[]) x in
- (List.rev whencode, List.rev init)
- | Ast0.CIRCLES(x) | Ast0.STARS(x) -> failwith "not possible for an initlist"
-
-and initialiser i =
- rewrap i no_isos
- (match Ast0.unwrap i with
- Ast0.MetaInit(name,_) -> Ast.MetaInit(mcode name,unitary,false)
- | Ast0.InitExpr(exp) -> Ast.InitExpr(expression exp)
- | Ast0.InitList(lb,initlist,rb) ->
- let (whencode,initlist) = strip_idots initlist in
- Ast.InitList(mcode lb,List.map initialiser initlist,mcode rb,
- List.map initialiser whencode)
- | Ast0.InitGccExt(designators,eq,ini) ->
- Ast.InitGccExt(List.map designator designators,mcode eq,
- initialiser ini)
- | Ast0.InitGccName(name,eq,ini) ->
- Ast.InitGccName(ident name,mcode eq,initialiser ini)
- | Ast0.IComma(comma) -> Ast.IComma(mcode comma)
- | Ast0.Idots(_,_) -> failwith "Idots should have been removed"
- | Ast0.OptIni(ini) -> Ast.OptIni(initialiser ini)
- | Ast0.UniqueIni(ini) -> Ast.UniqueIni(initialiser ini))
-
-and designator = function
- Ast0.DesignatorField(dot,id) -> Ast.DesignatorField(mcode dot,ident id)
- | Ast0.DesignatorIndex(lb,exp,rb) ->
- Ast.DesignatorIndex(mcode lb, expression exp, mcode rb)
- | Ast0.DesignatorRange(lb,min,dots,max,rb) ->
- Ast.DesignatorRange(mcode lb,expression min,mcode dots,expression max,
- mcode rb)
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef p =
- rewrap p no_isos
- (match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> Ast.VoidParam(typeC ty)
- | Ast0.Param(ty,id) -> Ast.Param(typeC ty,get_option ident id)
- | Ast0.MetaParam(name,_) ->
- Ast.MetaParam(mcode name,unitary,false)
- | Ast0.MetaParamList(name,Some lenname,_) ->
- Ast.MetaParamList(mcode name,Some(mcode lenname,unitary,false),
- unitary,false)
- | Ast0.MetaParamList(name,None,_) ->
- Ast.MetaParamList(mcode name,None,unitary,false)
- | Ast0.PComma(cm) -> Ast.PComma(mcode cm)
- | Ast0.Pdots(dots) -> Ast.Pdots(mcode dots)
- | Ast0.Pcircles(dots) -> Ast.Pcircles(mcode dots)
- | Ast0.OptParam(param) -> Ast.OptParam(parameterTypeDef param)
- | Ast0.UniqueParam(param) -> Ast.UniqueParam(parameterTypeDef param))
-
-and parameter_list l = dots parameterTypeDef l
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and statement s =
- let rec statement seqible s =
- let rewrap_stmt ast0 ast =
- let befaft =
- match Ast0.get_dots_bef_aft s with
- Ast0.NoDots -> Ast.NoDots
- | Ast0.DroppingBetweenDots s ->
- Ast.DroppingBetweenDots (statement seqible s,get_ctr())
- | Ast0.AddingBetweenDots s ->
- Ast.AddingBetweenDots (statement seqible s,get_ctr()) in
- Ast.set_dots_bef_aft befaft (rewrap ast0 no_isos ast) in
- let rewrap_rule_elem ast0 ast =
- rewrap ast0 (do_isos (Ast0.get_iso ast0)) ast in
- rewrap_stmt s
- (match Ast0.unwrap s with
- Ast0.Decl((_,bef),decl) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.Decl(convert_mcodekind bef,
- check_allminus.V0.combiner_statement s,
- declaration decl)))
- | Ast0.Seq(lbrace,body,rbrace) ->
- let lbrace = mcode lbrace in
- let (decls,body) = separate_decls seqible body in
- let rbrace = mcode rbrace in
- Ast.Seq(iso_tokenwrap lbrace s (Ast.SeqStart(lbrace))
- (do_isos (Ast0.get_iso s)),
- decls,body,
- tokenwrap rbrace s (Ast.SeqEnd(rbrace)))
- | Ast0.ExprStatement(exp,sem) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.ExprStatement(expression exp,mcode sem)))
- | Ast0.IfThen(iff,lp,exp,rp,branch,(_,aft)) ->
- Ast.IfThen
- (rewrap_rule_elem s
- (Ast.IfHeader(mcode iff,mcode lp,expression exp,mcode rp)),
- statement Ast.NotSequencible branch,
- ([],[],[],convert_mcodekind aft))
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,(_,aft)) ->
- let els = mcode els in
- Ast.IfThenElse
- (rewrap_rule_elem s
- (Ast.IfHeader(mcode iff,mcode lp,expression exp,mcode rp)),
- statement Ast.NotSequencible branch1,
- tokenwrap els s (Ast.Else(els)),
- statement Ast.NotSequencible branch2,
- ([],[],[],convert_mcodekind aft))
- | Ast0.While(wh,lp,exp,rp,body,(_,aft)) ->
- Ast.While(rewrap_rule_elem s
- (Ast.WhileHeader
- (mcode wh,mcode lp,expression exp,mcode rp)),
- statement Ast.NotSequencible body,
- ([],[],[],convert_mcodekind aft))
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- let wh = mcode wh in
- Ast.Do(rewrap_rule_elem s (Ast.DoHeader(mcode d)),
- statement Ast.NotSequencible body,
- tokenwrap wh s
- (Ast.WhileTail(wh,mcode lp,expression exp,mcode rp,
- mcode sem)))
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,(_,aft)) ->
- let fr = mcode fr in
- let lp = mcode lp in
- let exp1 = get_option expression exp1 in
- let sem1 = mcode sem1 in
- let exp2 = get_option expression exp2 in
- let sem2= mcode sem2 in
- let exp3 = get_option expression exp3 in
- let rp = mcode rp in
- let body = statement Ast.NotSequencible body in
- Ast.For(rewrap_rule_elem s
- (Ast.ForHeader(fr,lp,exp1,sem1,exp2,sem2,exp3,rp)),
- body,([],[],[],convert_mcodekind aft))
- | Ast0.Iterator(nm,lp,args,rp,body,(_,aft)) ->
- Ast.Iterator(rewrap_rule_elem s
- (Ast.IteratorHeader
- (ident nm,mcode lp,
- dots expression args,
- mcode rp)),
- statement Ast.NotSequencible body,
- ([],[],[],convert_mcodekind aft))
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- let switch = mcode switch in
- let lp = mcode lp in
- let exp = expression exp in
- let rp = mcode rp in
- let lb = mcode lb in
- let cases = List.map case_line (Ast0.undots cases) in
- let rb = mcode rb in
- Ast.Switch(rewrap_rule_elem s (Ast.SwitchHeader(switch,lp,exp,rp)),
- tokenwrap lb s (Ast.SeqStart(lb)),
- cases,
- tokenwrap rb s (Ast.SeqEnd(rb)))
- | Ast0.Break(br,sem) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Break(mcode br,mcode sem)))
- | Ast0.Continue(cont,sem) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Continue(mcode cont,mcode sem)))
- | Ast0.Label(l,dd) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Label(ident l,mcode dd)))
- | Ast0.Goto(goto,l,sem) ->
- Ast.Atomic
- (rewrap_rule_elem s (Ast.Goto(mcode goto,ident l,mcode sem)))
- | Ast0.Return(ret,sem) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Return(mcode ret,mcode sem)))
- | Ast0.ReturnExpr(ret,exp,sem) ->
- Ast.Atomic
- (rewrap_rule_elem s
- (Ast.ReturnExpr(mcode ret,expression exp,mcode sem)))
- | Ast0.MetaStmt(name,_) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.MetaStmt(mcode name,unitary,seqible,false)))
- | Ast0.MetaStmtList(name,_) ->
- Ast.Atomic(rewrap_rule_elem s
- (Ast.MetaStmtList(mcode name,unitary,false)))
- | Ast0.TopExp(exp) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.TopExp(expression exp)))
- | Ast0.Exp(exp) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Exp(expression exp)))
- | Ast0.TopInit(init) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.TopInit(initialiser init)))
- | Ast0.Ty(ty) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Ty(typeC ty)))
- | Ast0.Disj(_,rule_elem_dots_list,_,_) ->
- Ast.Disj(List.map (function x -> statement_dots seqible x)
- rule_elem_dots_list)
- | Ast0.Nest(_,rule_elem_dots,_,whn,multi) ->
- Ast.Nest
- (statement_dots Ast.Sequencible rule_elem_dots,
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn,
- multi,[],[])
- | Ast0.Dots(d,whn) ->
- let d = mcode d in
- let whn =
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn in
- Ast.Dots(d,whn,[],[])
- | Ast0.Circles(d,whn) ->
- let d = mcode d in
- let whn =
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn in
- Ast.Circles(d,whn,[],[])
- | Ast0.Stars(d,whn) ->
- let d = mcode d in
- let whn =
- List.map
- (whencode (statement_dots Ast.Sequencible)
- (statement Ast.NotSequencible))
- whn in
- Ast.Stars(d,whn,[],[])
- | Ast0.FunDecl((_,bef),fi,name,lp,params,rp,lbrace,body,rbrace) ->
- let fi = List.map fninfo fi in
- let name = ident name in
- let lp = mcode lp in
- let params = parameter_list params in
- let rp = mcode rp in
- let lbrace = mcode lbrace in
- let (decls,body) = separate_decls seqible body in
- let rbrace = mcode rbrace in
- let allminus = check_allminus.V0.combiner_statement s in
- Ast.FunDecl(rewrap_rule_elem s
- (Ast.FunHeader(convert_mcodekind bef,
- allminus,fi,name,lp,params,rp)),
- tokenwrap lbrace s (Ast.SeqStart(lbrace)),
- decls,body,
- tokenwrap rbrace s (Ast.SeqEnd(rbrace)))
- | Ast0.Include(inc,str) ->
- Ast.Atomic(rewrap_rule_elem s (Ast.Include(mcode inc,mcode str)))
- | Ast0.Define(def,id,params,body) ->
- Ast.Define
- (rewrap_rule_elem s
- (Ast.DefineHeader
- (mcode def,ident id, define_parameters params)),
- statement_dots Ast.NotSequencible (*not sure*) body)
- | Ast0.OptStm(stm) -> Ast.OptStm(statement seqible stm)
- | Ast0.UniqueStm(stm) -> Ast.UniqueStm(statement seqible stm))
-
- and define_parameters p =
- rewrap p no_isos
- (match Ast0.unwrap p with
- Ast0.NoParams -> Ast.NoParams
- | Ast0.DParams(lp,params,rp) ->
- Ast.DParams(mcode lp,
- dots define_param params,
- mcode rp))
-
- and define_param p =
- rewrap p no_isos
- (match Ast0.unwrap p with
- Ast0.DParam(id) -> Ast.DParam(ident id)
- | Ast0.DPComma(comma) -> Ast.DPComma(mcode comma)
- | Ast0.DPdots(d) -> Ast.DPdots(mcode d)
- | Ast0.DPcircles(c) -> Ast.DPcircles(mcode c)
- | Ast0.OptDParam(dp) -> Ast.OptDParam(define_param dp)
- | Ast0.UniqueDParam(dp) -> Ast.UniqueDParam(define_param dp))
-
- and whencode notfn alwaysfn = function
- Ast0.WhenNot a -> Ast.WhenNot (notfn a)
- | Ast0.WhenAlways a -> Ast.WhenAlways (alwaysfn a)
- | Ast0.WhenModifier(x) -> Ast.WhenModifier(x)
- | x ->
- let rewrap_rule_elem ast0 ast =
- rewrap ast0 (do_isos (Ast0.get_iso ast0)) ast in
- match x with
- Ast0.WhenNotTrue(e) ->
- Ast.WhenNotTrue(rewrap_rule_elem e (Ast.Exp(expression e)))
- | Ast0.WhenNotFalse(e) ->
- Ast.WhenNotFalse(rewrap_rule_elem e (Ast.Exp(expression e)))
- | _ -> failwith "not possible"
-
- and process_list seqible isos = function
- [] -> []
- | x::rest ->
- let first = statement seqible x in
- let first =
- if !Flag.track_iso_usage
- then Ast.set_isos first (isos@(Ast.get_isos first))
- else first in
- (match Ast0.unwrap x with
- Ast0.Dots(_,_) | Ast0.Nest(_) ->
- first::(process_list (Ast.SequencibleAfterDots []) no_isos rest)
- | _ ->
- first::(process_list Ast.Sequencible no_isos rest))
-
- and statement_dots seqible d =
- let isos = do_isos (Ast0.get_iso d) in
- rewrap d no_isos
- (match Ast0.unwrap d with
- Ast0.DOTS(x) -> Ast.DOTS(process_list seqible isos x)
- | Ast0.CIRCLES(x) -> Ast.CIRCLES(process_list seqible isos x)
- | Ast0.STARS(x) -> Ast.STARS(process_list seqible isos x))
-
- and separate_decls seqible d =
- let rec collect_decls = function
- [] -> ([],[])
- | (x::xs) as l ->
- (match Ast0.unwrap x with
- Ast0.Decl(_) ->
- let (decls,other) = collect_decls xs in
- (x :: decls,other)
- | Ast0.Dots(_,_) | Ast0.Nest(_,_,_,_,_) ->
- let (decls,other) = collect_decls xs in
- (match decls with
- [] -> ([],x::other)
- | _ -> (x :: decls,other))
- | Ast0.Disj(starter,stmt_dots_list,mids,ender) ->
- let disjs = List.map collect_dot_decls stmt_dots_list in
- let all_decls = List.for_all (function (_,s) -> s=[]) disjs in
- if all_decls
- then
- let (decls,other) = collect_decls xs in
- (x :: decls,other)
- else ([],l)
- | _ -> ([],l))
-
- and collect_dot_decls d =
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> collect_decls x
- | Ast0.CIRCLES(x) -> collect_decls x
- | Ast0.STARS(x) -> collect_decls x in
-
- let process l d fn =
- let (decls,other) = collect_decls l in
- (rewrap d no_isos (fn (List.map (statement seqible) decls)),
- rewrap d no_isos
- (fn (process_list seqible (do_isos (Ast0.get_iso d)) other))) in
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> process x d (function x -> Ast.DOTS x)
- | Ast0.CIRCLES(x) -> process x d (function x -> Ast.CIRCLES x)
- | Ast0.STARS(x) -> process x d (function x -> Ast.STARS x) in
-
- statement Ast.Sequencible s
-
-and fninfo = function
- Ast0.FStorage(stg) -> Ast.FStorage(mcode stg)
- | Ast0.FType(ty) -> Ast.FType(typeC ty)
- | Ast0.FInline(inline) -> Ast.FInline(mcode inline)
- | Ast0.FAttr(attr) -> Ast.FAttr(mcode attr)
-
-and option_to_list = function
- Some x -> [x]
- | None -> []
-
-and case_line c =
- rewrap c no_isos
- (match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- let def = mcode def in
- let colon = mcode colon in
- let code = dots statement code in
- Ast.CaseLine(rewrap c no_isos (Ast.Default(def,colon)),code)
- | Ast0.Case(case,exp,colon,code) ->
- let case = mcode case in
- let exp = expression exp in
- let colon = mcode colon in
- let code = dots statement code in
- Ast.CaseLine(rewrap c no_isos (Ast.Case(case,exp,colon)),code)
- | Ast0.OptCase(case) -> Ast.OptCase(case_line case))
-
-and statement_dots l = dots statement l
-
-(* --------------------------------------------------------------------- *)
-
-(* what is possible is only what is at the top level in an iso *)
-and anything = function
- Ast0.DotsExprTag(d) -> Ast.ExprDotsTag(expression_dots d)
- | Ast0.DotsParamTag(d) -> Ast.ParamDotsTag(parameter_list d)
- | Ast0.DotsInitTag(d) -> failwith "not possible"
- | Ast0.DotsStmtTag(d) -> Ast.StmtDotsTag(statement_dots d)
- | Ast0.DotsDeclTag(d) -> Ast.DeclDotsTag(declaration_dots d)
- | Ast0.DotsCaseTag(d) -> failwith "not possible"
- | Ast0.IdentTag(d) -> Ast.IdentTag(ident d)
- | Ast0.ExprTag(d) -> Ast.ExpressionTag(expression d)
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "only in isos, not converted to ast"
- | Ast0.TypeCTag(d) -> Ast.FullTypeTag(typeC d)
- | Ast0.ParamTag(d) -> Ast.ParamTag(parameterTypeDef d)
- | Ast0.InitTag(d) -> Ast.InitTag(initialiser d)
- | Ast0.DeclTag(d) -> Ast.DeclarationTag(declaration d)
- | Ast0.StmtTag(d) -> Ast.StatementTag(statement d)
- | Ast0.CaseLineTag(d) -> Ast.CaseLineTag(case_line d)
- | Ast0.TopTag(d) -> Ast.Code(top_level d)
- | Ast0.IsoWhenTag(_) -> failwith "not possible"
- | Ast0.IsoWhenTTag(_) -> failwith "not possible"
- | Ast0.IsoWhenFTag(_) -> failwith "not possible"
- | Ast0.MetaPosTag _ -> failwith "not possible"
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-(* top level isos are probably lost to tracking *)
-
-and top_level t =
- rewrap t no_isos
- (match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- Ast.FILEINFO(mcode old_file,mcode new_file)
- | Ast0.DECL(stmt) -> Ast.DECL(statement stmt)
- | Ast0.CODE(rule_elem_dots) ->
- Ast.CODE(statement_dots rule_elem_dots)
- | Ast0.ERRORWORDS(exps) -> Ast.ERRORWORDS(List.map expression exps)
- | Ast0.OTHER(_) -> failwith "eliminated by top_level")
-
-(* --------------------------------------------------------------------- *)
-(* Entry point for minus code *)
-
-(* Inline_mcodes is very important - sends + code attached to the - code
-down to the mcodes. The functions above can only be used when there is no
-attached + code, eg in + code itself. *)
-let ast0toast_toplevel x =
- inline_mcodes.V0.combiner_top_level x;
- top_level x
-
-let ast0toast name deps dropped exists x is_exp ruletype =
- List.iter inline_mcodes.V0.combiner_top_level x;
- Ast.CocciRule
- (name,(deps,dropped,exists),List.map top_level x,is_exp,ruletype)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-type info = { line : int; column : int;
- strbef : string list; straft : string list }
-type line = int
-type meta_name = string * string
-(* need to be careful about rewrapping, to avoid duplicating pos info
-currently, the pos info is always None until asttoctl2. *)
-type 'a wrap =
- {node : 'a;
- node_line : line;
- free_vars : meta_name list; (*free vars*)
- minus_free_vars : meta_name list; (*minus free vars*)
- fresh_vars : meta_name list; (*fresh vars*)
- inherited : meta_name list; (*inherited vars*)
- saved_witness : meta_name list; (*witness vars*)
- bef_aft : dots_bef_aft;
- (* the following is for or expressions *)
- pos_info : meta_name mcode option; (* pos info, try not to duplicate *)
- true_if_test_exp : bool;(* true if "test_exp from iso", only for exprs *)
- (* isos relevant to the term; ultimately only used for rule_elems *)
- iso_info : (string*anything) list }
-
-and 'a befaft =
- BEFORE of 'a list list
- | AFTER of 'a list list
- | BEFOREAFTER of 'a list list * 'a list list
- | NOTHING
-
-and 'a mcode = 'a * info * mcodekind * meta_pos (* pos variable *)
- (* pos is an offset indicating where in the C code the mcodekind has an
- effect *)
- and mcodekind =
- MINUS of pos * anything list list
- | CONTEXT of pos * anything befaft
- | PLUS
- and fixpos =
- Real of int (* charpos *) | Virt of int * int (* charpos + offset *)
- and pos = NoPos | DontCarePos | FixPos of (fixpos * fixpos)
-
-and dots_bef_aft =
- NoDots
- | AddingBetweenDots of statement * int (*index of let var*)
- | DroppingBetweenDots of statement * int (*index of let var*)
-
-and inherited = Type_cocci.inherited
-and keep_binding = Type_cocci.keep_binding
-and multi = bool (*true if a nest is one or more, false if it is zero or more*)
-
-and end_info =
- meta_name list (*free vars*) * meta_name list (*inherited vars*) *
- meta_name list (*witness vars*) * mcodekind
-
-(* --------------------------------------------------------------------- *)
-(* Metavariables *)
-
-and arity = UNIQUE | OPT | MULTI | NONE
-
-and metavar =
- MetaIdDecl of arity * meta_name (* name *)
- | MetaFreshIdDecl of arity * meta_name (* name *)
- | MetaTypeDecl of arity * meta_name (* name *)
- | MetaListlenDecl of meta_name (* name *)
- | MetaParamDecl of arity * meta_name (* name *)
- | MetaParamListDecl of arity * meta_name (*name*) * meta_name option (*len*)
- | MetaConstDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaErrDecl of arity * meta_name (* name *)
- | MetaExpDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaIdExpDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaLocalIdExpDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaExpListDecl of arity * meta_name (*name*) * meta_name option (*len*)
- | MetaStmDecl of arity * meta_name (* name *)
- | MetaStmListDecl of arity * meta_name (* name *)
- | MetaFuncDecl of arity * meta_name (* name *)
- | MetaLocalFuncDecl of arity * meta_name (* name *)
- | MetaPosDecl of arity * meta_name (* name *)
- | MetaDeclarerDecl of arity * meta_name (* name *)
- | MetaIteratorDecl of arity * meta_name (* name *)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-and 'a base_dots =
- DOTS of 'a list
- | CIRCLES of 'a list
- | STARS of 'a list
-
-and 'a dots = 'a base_dots wrap
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-and base_ident =
- Id of string mcode
-
- | MetaId of meta_name mcode * ident list * keep_binding * inherited
- | MetaFunc of meta_name mcode * ident list * keep_binding * inherited
- | MetaLocalFunc of meta_name mcode * ident list * keep_binding * inherited
-
- | OptIdent of ident
- | UniqueIdent of ident
-
-and ident = base_ident wrap
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-and base_expression =
- Ident of ident
- | Constant of constant mcode
- | FunCall of expression * string mcode (* ( *) *
- expression dots * string mcode (* ) *)
- | Assignment of expression * assignOp mcode * expression *
- bool (* true if it can match an initialization *)
- | CondExpr of expression * string mcode (* ? *) * expression option *
- string mcode (* : *) * expression
- | Postfix of expression * fixOp mcode
- | Infix of expression * fixOp mcode
- | Unary of expression * unaryOp mcode
- | Binary of expression * binaryOp mcode * expression
- | Nested of expression * binaryOp mcode * expression
- | ArrayAccess of expression * string mcode (* [ *) * expression *
- string mcode (* ] *)
- | RecordAccess of expression * string mcode (* . *) * ident
- | RecordPtAccess of expression * string mcode (* -> *) * ident
- | Cast of string mcode (* ( *) * fullType * string mcode (* ) *) *
- expression
- | SizeOfExpr of string mcode (* sizeof *) * expression
- | SizeOfType of string mcode (* sizeof *) * string mcode (* ( *) *
- fullType * string mcode (* ) *)
- | TypeExp of fullType (*type name used as an expression, only in
- arg or #define*)
-
- | Paren of string mcode (* ( *) * expression *
- string mcode (* ) *)
-
- | MetaErr of meta_name mcode * expression list * keep_binding *
- inherited
- | MetaExpr of meta_name mcode * expression list * keep_binding *
- Type_cocci.typeC list option * form * inherited
- | MetaExprList of meta_name mcode * listlen option * keep_binding *
- inherited (* only in arg lists *)
-
- | EComma of string mcode (* only in arg lists *)
-
- | DisjExpr of expression list
- | NestExpr of expression dots * expression option * multi
-
- (* can appear in arg lists, and also inside Nest, as in:
- if(< ... X ... Y ...>)
- In the following, the expression option is the WHEN *)
- | Edots of string mcode (* ... *) * expression option
- | Ecircles of string mcode (* ooo *) * expression option
- | Estars of string mcode (* *** *) * expression option
-
- | OptExp of expression
- | UniqueExp of expression
-
-(* ANY = int E; ID = idexpression int X; CONST = constant int X; *)
-and form = ANY | ID | LocalID | CONST (* form for MetaExp *)
-
-and expression = base_expression wrap
-
-and listlen = meta_name mcode * keep_binding * inherited
-
-and unaryOp = GetRef | DeRef | UnPlus | UnMinus | Tilde | Not
-and assignOp = SimpleAssign | OpAssign of arithOp
-and fixOp = Dec | Inc
-
-and binaryOp = Arith of arithOp | Logical of logicalOp
-and arithOp =
- Plus | Minus | Mul | Div | Mod | DecLeft | DecRight | And | Or | Xor
-and logicalOp = Inf | Sup | InfEq | SupEq | Eq | NotEq | AndLog | OrLog
-
-and constant =
- String of string
- | Char of string
- | Int of string
- | Float of string
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and base_fullType =
- Type of const_vol mcode option * typeC
- | DisjType of fullType list (* only after iso *)
- | OptType of fullType
- | UniqueType of fullType
-
-and base_typeC =
- BaseType of baseType * string mcode list (* Yoann style *)
- | SignedT of sign mcode * typeC option
- | Pointer of fullType * string mcode (* * *)
- | FunctionPointer of fullType *
- string mcode(* ( *)*string mcode(* * *)*string mcode(* ) *)*
- string mcode (* ( *)*parameter_list*string mcode(* ) *)
-
- (* used for the automatic managment of prototypes *)
- | FunctionType of bool (* true if all minus for dropping return type *) *
- fullType option *
- string mcode (* ( *) * parameter_list *
- string mcode (* ) *)
-
- | Array of fullType * string mcode (* [ *) *
- expression option * string mcode (* ] *)
- | EnumName of string mcode (*enum*) * ident (* name *)
- | StructUnionName of structUnion mcode * ident option (* name *)
- | StructUnionDef of fullType (* either StructUnionName or metavar *) *
- string mcode (* { *) * declaration dots * string mcode (* } *)
- | TypeName of string mcode
-
- | MetaType of meta_name mcode * keep_binding * inherited
-
-and fullType = base_fullType wrap
-and typeC = base_typeC wrap
-
-and baseType = VoidType | CharType | ShortType | IntType | DoubleType
- | FloatType | LongType | LongLongType
-
-and structUnion = Struct | Union
-
-and sign = Signed | Unsigned
-
-and const_vol = Const | Volatile
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and base_declaration =
- Init of storage mcode option * fullType * ident * string mcode (*=*) *
- initialiser * string mcode (*;*)
- | UnInit of storage mcode option * fullType * ident * string mcode (* ; *)
- | TyDecl of fullType * string mcode (* ; *)
- | MacroDecl of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *) * string mcode (* ; *)
- | Typedef of string mcode (*typedef*) * fullType *
- typeC (* either TypeName or metavar *) * string mcode (*;*)
- | DisjDecl of declaration list
- (* Ddots is for a structure declaration *)
- | Ddots of string mcode (* ... *) * declaration option (* whencode *)
-
- | MetaDecl of meta_name mcode * keep_binding * inherited
-
- | OptDecl of declaration
- | UniqueDecl of declaration
-
-and declaration = base_declaration wrap
-
-(* --------------------------------------------------------------------- *)
-(* Initializers *)
-
-and base_initialiser =
- InitExpr of expression
- | InitList of string mcode (*{*) * initialiser list * string mcode (*}*) *
- initialiser list (* whencode: elements that shouldn't appear in init *)
- | InitGccDotName of
- string mcode (*.*) * ident (* name *) * string mcode (*=*) *
- initialiser (* gccext: *)
- | InitGccName of ident (* name *) * string mcode (*:*) *
- initialiser
- | InitGccIndex of
- string mcode (*[*) * expression * string mcode (*]*) *
- string mcode (*=*) * initialiser
- | InitGccRange of
- string mcode (*[*) * expression * string mcode (*...*) *
- expression * string mcode (*]*) * string mcode (*=*) * initialiser
- | IComma of string mcode (* , *)
-
- | OptIni of initialiser
- | UniqueIni of initialiser
-
-and initialiser = base_initialiser wrap
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and base_parameterTypeDef =
- VoidParam of fullType
- | Param of fullType * ident option
-
- | MetaParam of meta_name mcode * keep_binding * inherited
- | MetaParamList of meta_name mcode * listlen option * keep_binding *
- inherited
-
- | PComma of string mcode
-
- | Pdots of string mcode (* ... *)
- | Pcircles of string mcode (* ooo *)
-
- | OptParam of parameterTypeDef
- | UniqueParam of parameterTypeDef
-
-and parameterTypeDef = base_parameterTypeDef wrap
-
-and parameter_list = parameterTypeDef dots
-
-(* --------------------------------------------------------------------- *)
-(* #define Parameters *)
-
-and base_define_param =
- DParam of ident
- | DPComma of string mcode
- | DPdots of string mcode (* ... *)
- | DPcircles of string mcode (* ooo *)
- | OptDParam of define_param
- | UniqueDParam of define_param
-
-and define_param = base_define_param wrap
-
-and base_define_parameters =
- NoParams (* not parameter list, not an empty one *)
- | DParams of string mcode(*( *) * define_param dots * string mcode(* )*)
-
-and define_parameters = base_define_parameters wrap
-
-(* --------------------------------------------------------------------- *)
-(* positions *)
-
-(* PER = keep bindings separate, ALL = collect them *)
-and meta_collect = PER | ALL
-
-and meta_pos =
- MetaPos of meta_name mcode * meta_name list *
- meta_collect * keep_binding * inherited
- | NoMetaPos
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-
-and storage = Static | Auto | Register | Extern
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and base_rule_elem =
- FunHeader of mcodekind (* before the function header *) *
- bool (* true if all minus, for dropping static, etc *) *
- fninfo list * ident (* name *) *
- string mcode (* ( *) * parameter_list *
- string mcode (* ) *)
- | Decl of mcodekind (* before the decl *) *
- bool (* true if all minus *) * declaration
-
- | SeqStart of string mcode (* { *)
- | SeqEnd of string mcode (* } *)
-
- | ExprStatement of expression * string mcode (*;*)
- | IfHeader of string mcode (* if *) * string mcode (* ( *) *
- expression * string mcode (* ) *)
- | Else of string mcode (* else *)
- | WhileHeader of string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *)
- | DoHeader of string mcode (* do *)
- | WhileTail of string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- string mcode (* ; *)
- | ForHeader of string mcode (* for *) * string mcode (* ( *) *
- expression option * string mcode (*;*) *
- expression option * string mcode (*;*) *
- expression option * string mcode (* ) *)
- | IteratorHeader of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *)
- | SwitchHeader of string mcode (* switch *) * string mcode (* ( *) *
- expression * string mcode (* ) *)
- | Break of string mcode (* break *) * string mcode (* ; *)
- | Continue of string mcode (* continue *) * string mcode (* ; *)
- | Label of ident * string mcode (* : *)
- | Goto of string mcode (* goto *) * ident * string mcode (* ; *)
- | Return of string mcode (* return *) * string mcode (* ; *)
- | ReturnExpr of string mcode (* return *) * expression *
- string mcode (* ; *)
-
- | MetaRuleElem of meta_name mcode * keep_binding * inherited
- | MetaStmt of meta_name mcode * keep_binding * metaStmtInfo *
- inherited
- | MetaStmtList of meta_name mcode * keep_binding * inherited
-
- | Exp of expression (* matches a subterm *)
- | TopExp of expression (* for macros body, exp at top level,
- not subexp *)
- | Ty of fullType (* only at SP top level, matches a subterm *)
- | TopInit of initialiser (* only at top level *)
- | Include of string mcode (*#include*) * inc_file mcode (*file *)
- | DefineHeader of string mcode (* #define *) * ident (* name *) *
- define_parameters (*params*)
- | Case of string mcode (* case *) * expression * string mcode (*:*)
- | Default of string mcode (* default *) * string mcode (*:*)
- | DisjRuleElem of rule_elem list
-
-and fninfo =
- FStorage of storage mcode
- | FType of fullType
- | FInline of string mcode
- | FAttr of string mcode
-
-and metaStmtInfo =
- NotSequencible | SequencibleAfterDots of dots_whencode list | Sequencible
-
-and rule_elem = base_rule_elem wrap
-
-and base_statement =
- Seq of rule_elem (* { *) * statement dots *
- statement dots * rule_elem (* } *)
- | IfThen of rule_elem (* header *) * statement * end_info (* endif *)
- | IfThenElse of rule_elem (* header *) * statement *
- rule_elem (* else *) * statement * end_info (* endif *)
- | While of rule_elem (* header *) * statement * end_info (*endwhile*)
- | Do of rule_elem (* do *) * statement * rule_elem (* tail *)
- | For of rule_elem (* header *) * statement * end_info (*endfor*)
- | Iterator of rule_elem (* header *) * statement * end_info (*enditer*)
- | Switch of rule_elem (* header *) * rule_elem (* { *) *
- case_line list * rule_elem (* } *)
- | Atomic of rule_elem
- | Disj of statement dots list
- | Nest of statement dots *
- (statement dots,statement) whencode list * multi *
- dots_whencode list * dots_whencode list
- | FunDecl of rule_elem (* header *) * rule_elem (* { *) *
- statement dots * statement dots * rule_elem (* } *)
- | Define of rule_elem (* header *) * statement dots
- | Dots of string mcode (* ... *) *
- (statement dots,statement) whencode list *
- dots_whencode list * dots_whencode list
- | Circles of string mcode (* ooo *) *
- (statement dots,statement) whencode list *
- dots_whencode list * dots_whencode list
- | Stars of string mcode (* *** *) *
- (statement dots,statement) whencode list *
- dots_whencode list * dots_whencode list
- | OptStm of statement
- | UniqueStm of statement
-
-and ('a,'b) whencode =
- WhenNot of 'a
- | WhenAlways of 'b
- | WhenModifier of when_modifier
- | WhenNotTrue of rule_elem (* useful for fvs *)
- | WhenNotFalse of rule_elem
-
-and when_modifier =
- (* The following removes the shortest path constraint. It can be used
- with other when modifiers *)
- WhenAny
- (* The following removes the special consideration of error paths. It
- can be used with other when modifiers *)
- | WhenStrict
- | WhenForall
- | WhenExists
-
-(* only used with asttoctl *)
-and dots_whencode =
- WParen of rule_elem * meta_name (*pren_var*)
- | Other of statement
- | Other_dots of statement dots
-
-and statement = base_statement wrap
-
-and base_case_line =
- CaseLine of rule_elem (* case/default header *) * statement dots
- | OptCase of case_line
-
-and case_line = base_case_line wrap
-
-and inc_file =
- Local of inc_elem list
- | NonLocal of inc_elem list
-
-and inc_elem =
- IncPath of string
- | IncDots
-
-and base_top_level =
- DECL of statement
- | CODE of statement dots
- | FILEINFO of string mcode (* old file *) * string mcode (* new file *)
- | ERRORWORDS of expression list
-
-and top_level = base_top_level wrap
-
-and rulename =
- CocciRulename of string option * dependency *
- string list * string list * exists * bool
- | GeneratedRulename of string option * dependency *
- string list * string list * exists * bool
- | ScriptRulename of string * dependency
-
-and ruletype = Normal | Generated
-
-and rule =
- CocciRule of string (* name *) *
- (dependency * string list (* dropped isos *) * exists) * top_level list
- * bool list * ruletype
- | ScriptRule of string * dependency * (string * meta_name) list * string
-
-and dependency =
- Dep of string (* rule applies for the current binding *)
- | AntiDep of string (* rule doesn't apply for the current binding *)
- | EverDep of string (* rule applies for some binding *)
- | NeverDep of string (* rule never applies for any binding *)
- | AndDep of dependency * dependency
- | OrDep of dependency * dependency
- | NoDep
-
-and rule_with_metavars = metavar list * rule
-
-and anything =
- FullTypeTag of fullType
- | BaseTypeTag of baseType
- | StructUnionTag of structUnion
- | SignTag of sign
- | IdentTag of ident
- | ExpressionTag of expression
- | ConstantTag of constant
- | UnaryOpTag of unaryOp
- | AssignOpTag of assignOp
- | FixOpTag of fixOp
- | BinaryOpTag of binaryOp
- | ArithOpTag of arithOp
- | LogicalOpTag of logicalOp
- | DeclarationTag of declaration
- | InitTag of initialiser
- | StorageTag of storage
- | IncFileTag of inc_file
- | Rule_elemTag of rule_elem
- | StatementTag of statement
- | CaseLineTag of case_line
- | ConstVolTag of const_vol
- | Token of string * info option
- | Code of top_level
- | ExprDotsTag of expression dots
- | ParamDotsTag of parameterTypeDef dots
- | StmtDotsTag of statement dots
- | DeclDotsTag of declaration dots
- | TypeCTag of typeC
- | ParamTag of parameterTypeDef
- | SgrepStartTag of string
- | SgrepEndTag of string
-
-(* --------------------------------------------------------------------- *)
-
-and exists = Exists | Forall | ReverseForall | Undetermined
-
-(* --------------------------------------------------------------------- *)
-
-let mkToken x = Token (x,None)
-
-(* --------------------------------------------------------------------- *)
-
-let rewrap model x = {model with node = x}
-let rewrap_mcode (_,a,b,c) x = (x,a,b,c)
-let unwrap x = x.node
-let unwrap_mcode (x,_,_,_) = x
-let get_mcodekind (_,_,x,_) = x
-let get_line x = x.node_line
-let get_mcode_line (_,l,_,_) = l.line
-let get_fvs x = x.free_vars
-let set_fvs fvs x = {x with free_vars = fvs}
-let get_mfvs x = x.minus_free_vars
-let set_mfvs mfvs x = {x with minus_free_vars = mfvs}
-let get_fresh x = x.fresh_vars
-let get_inherited x = x.inherited
-let get_saved x = x.saved_witness
-let get_dots_bef_aft x = x.bef_aft
-let set_dots_bef_aft d x = {x with bef_aft = d}
-let get_pos x = x.pos_info
-let set_pos x pos = {x with pos_info = pos}
-let get_test_exp x = x.true_if_test_exp
-let set_test_exp x = {x with true_if_test_exp = true}
-let get_isos x = x.iso_info
-let set_isos x isos = {x with iso_info = isos}
-let get_pos_var (_,_,_,p) = p
-let set_pos_var vr (a,b,c,_) = (a,b,c,vr)
-let drop_pos (a,b,c,_) = (a,b,c,NoMetaPos)
-
-let get_wcfvs (whencode : ('a wrap, 'b wrap) whencode list) =
- Common.union_all
- (List.map
- (function
- WhenNot(a) -> get_fvs a
- | WhenAlways(a) -> get_fvs a
- | WhenModifier(_) -> []
- | WhenNotTrue(e) -> get_fvs e
- | WhenNotFalse(e) -> get_fvs e)
- whencode)
-
-(* --------------------------------------------------------------------- *)
-
-let get_meta_name = function
- MetaIdDecl(ar,nm) -> nm
- | MetaFreshIdDecl(ar,nm) -> nm
- | MetaTypeDecl(ar,nm) -> nm
- | MetaListlenDecl(nm) -> nm
- | MetaParamDecl(ar,nm) -> nm
- | MetaParamListDecl(ar,nm,nm1) -> nm
- | MetaConstDecl(ar,nm,ty) -> nm
- | MetaErrDecl(ar,nm) -> nm
- | MetaExpDecl(ar,nm,ty) -> nm
- | MetaIdExpDecl(ar,nm,ty) -> nm
- | MetaLocalIdExpDecl(ar,nm,ty) -> nm
- | MetaExpListDecl(ar,nm,nm1) -> nm
- | MetaStmDecl(ar,nm) -> nm
- | MetaStmListDecl(ar,nm) -> nm
- | MetaFuncDecl(ar,nm) -> nm
- | MetaLocalFuncDecl(ar,nm) -> nm
- | MetaPosDecl(ar,nm) -> nm
- | MetaDeclarerDecl(ar,nm) -> nm
- | MetaIteratorDecl(ar,nm) -> nm
-
-(* --------------------------------------------------------------------- *)
-
-let no_info = { line = 0; column = 0; strbef = []; straft = [] }
-
-let make_term x =
- {node = x;
- node_line = 0;
- free_vars = [];
- minus_free_vars = [];
- fresh_vars = [];
- inherited = [];
- saved_witness = [];
- bef_aft = NoDots;
- pos_info = None;
- true_if_test_exp = false;
- iso_info = [] }
-
-let make_meta_rule_elem s d (fvs,fresh,inh) =
- {(make_term
- (MetaRuleElem((("",s),no_info,d,NoMetaPos),Type_cocci.Unitary,false)))
- with free_vars = fvs; fresh_vars = fresh; inherited = inh}
-
-let make_meta_decl s d (fvs,fresh,inh) =
- {(make_term
- (MetaDecl((("",s),no_info,d,NoMetaPos),Type_cocci.Unitary,false))) with
- free_vars = fvs; fresh_vars = fresh; inherited = inh}
-
-let make_mcode x = (x,no_info,CONTEXT(NoPos,NOTHING),NoMetaPos)
-
-(* --------------------------------------------------------------------- *)
-
-let equal_pos x y = x = y
-
-(* --------------------------------------------------------------------- *)
-
-let undots x =
- match unwrap x with
- DOTS e -> e
- | CIRCLES e -> e
- | STARS e -> e
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-type info = { line : int; column : int;
- strbef : string list; straft : string list }
-type line = int
-type meta_name = string * string
-(* need to be careful about rewrapping, to avoid duplicating pos info
-currently, the pos info is always None until asttoctl2. *)
-type 'a wrap =
- {node : 'a;
- node_line : line;
- free_vars : meta_name list; (*free vars*)
- minus_free_vars : meta_name list; (*minus free vars*)
- fresh_vars : meta_name list; (*fresh vars*)
- inherited : meta_name list; (*inherited vars*)
- saved_witness : meta_name list; (*witness vars*)
- bef_aft : dots_bef_aft;
- (* the following is for or expressions *)
- pos_info : meta_name mcode option; (* pos info, try not to duplicate *)
- true_if_test_exp : bool;(* true if "test_exp from iso", only for exprs *)
- (* isos relevant to the term; ultimately only used for rule_elems *)
- iso_info : (string*anything) list }
-
-and 'a befaft =
- BEFORE of 'a list list
- | AFTER of 'a list list
- | BEFOREAFTER of 'a list list * 'a list list
- | NOTHING
-
-and 'a mcode = 'a * info * mcodekind * meta_pos (* pos variable *)
- (* pos is an offset indicating where in the C code the mcodekind has an
- effect *)
- and mcodekind =
- MINUS of pos * anything list list
- | CONTEXT of pos * anything befaft
- | PLUS
- and fixpos =
- Real of int (* charpos *) | Virt of int * int (* charpos + offset *)
- and pos = NoPos | DontCarePos | FixPos of (fixpos * fixpos)
-
-and dots_bef_aft =
- NoDots
- | AddingBetweenDots of statement * int (*index of let var*)
- | DroppingBetweenDots of statement * int (*index of let var*)
-
-and inherited = Type_cocci.inherited
-and keep_binding = Type_cocci.keep_binding
-and multi = bool (*true if a nest is one or more, false if it is zero or more*)
-
-and end_info =
- meta_name list (*free vars*) * meta_name list (*inherited vars*) *
- meta_name list (*witness vars*) * mcodekind
-
-(* --------------------------------------------------------------------- *)
-(* Metavariables *)
-
-and arity = UNIQUE | OPT | MULTI | NONE
-
-and metavar =
- MetaIdDecl of arity * meta_name (* name *)
- | MetaFreshIdDecl of arity * meta_name (* name *)
- | MetaTypeDecl of arity * meta_name (* name *)
- | MetaInitDecl of arity * meta_name (* name *)
- | MetaListlenDecl of meta_name (* name *)
- | MetaParamDecl of arity * meta_name (* name *)
- | MetaParamListDecl of arity * meta_name (*name*) * meta_name option (*len*)
- | MetaConstDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaErrDecl of arity * meta_name (* name *)
- | MetaExpDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaIdExpDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaLocalIdExpDecl of
- arity * meta_name (* name *) * Type_cocci.typeC list option
- | MetaExpListDecl of arity * meta_name (*name*) * meta_name option (*len*)
- | MetaStmDecl of arity * meta_name (* name *)
- | MetaStmListDecl of arity * meta_name (* name *)
- | MetaFuncDecl of arity * meta_name (* name *)
- | MetaLocalFuncDecl of arity * meta_name (* name *)
- | MetaPosDecl of arity * meta_name (* name *)
- | MetaDeclarerDecl of arity * meta_name (* name *)
- | MetaIteratorDecl of arity * meta_name (* name *)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-and 'a base_dots =
- DOTS of 'a list
- | CIRCLES of 'a list
- | STARS of 'a list
-
-and 'a dots = 'a base_dots wrap
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-and base_ident =
- Id of string mcode
-
- | MetaId of meta_name mcode * ident list * keep_binding * inherited
- | MetaFunc of meta_name mcode * ident list * keep_binding * inherited
- | MetaLocalFunc of meta_name mcode * ident list * keep_binding * inherited
-
- | OptIdent of ident
- | UniqueIdent of ident
-
-and ident = base_ident wrap
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-and base_expression =
- Ident of ident
- | Constant of constant mcode
- | FunCall of expression * string mcode (* ( *) *
- expression dots * string mcode (* ) *)
- | Assignment of expression * assignOp mcode * expression *
- bool (* true if it can match an initialization *)
- | CondExpr of expression * string mcode (* ? *) * expression option *
- string mcode (* : *) * expression
- | Postfix of expression * fixOp mcode
- | Infix of expression * fixOp mcode
- | Unary of expression * unaryOp mcode
- | Binary of expression * binaryOp mcode * expression
- | Nested of expression * binaryOp mcode * expression
- | ArrayAccess of expression * string mcode (* [ *) * expression *
- string mcode (* ] *)
- | RecordAccess of expression * string mcode (* . *) * ident
- | RecordPtAccess of expression * string mcode (* -> *) * ident
- | Cast of string mcode (* ( *) * fullType * string mcode (* ) *) *
- expression
- | SizeOfExpr of string mcode (* sizeof *) * expression
- | SizeOfType of string mcode (* sizeof *) * string mcode (* ( *) *
- fullType * string mcode (* ) *)
- | TypeExp of fullType (*type name used as an expression, only in
- arg or #define*)
-
- | Paren of string mcode (* ( *) * expression *
- string mcode (* ) *)
-
- | MetaErr of meta_name mcode * expression list * keep_binding *
- inherited
- | MetaExpr of meta_name mcode * expression list * keep_binding *
- Type_cocci.typeC list option * form * inherited
- | MetaExprList of meta_name mcode * listlen option * keep_binding *
- inherited (* only in arg lists *)
-
- | EComma of string mcode (* only in arg lists *)
-
- | DisjExpr of expression list
- | NestExpr of expression dots * expression option * multi
-
- (* can appear in arg lists, and also inside Nest, as in:
- if(< ... X ... Y ...>)
- In the following, the expression option is the WHEN *)
- | Edots of string mcode (* ... *) * expression option
- | Ecircles of string mcode (* ooo *) * expression option
- | Estars of string mcode (* *** *) * expression option
-
- | OptExp of expression
- | UniqueExp of expression
-
-(* ANY = int E; ID = idexpression int X; CONST = constant int X; *)
-and form = ANY | ID | LocalID | CONST (* form for MetaExp *)
-
-and expression = base_expression wrap
-
-and listlen = meta_name mcode * keep_binding * inherited
-
-and unaryOp = GetRef | DeRef | UnPlus | UnMinus | Tilde | Not
-and assignOp = SimpleAssign | OpAssign of arithOp
-and fixOp = Dec | Inc
-
-and binaryOp = Arith of arithOp | Logical of logicalOp
-and arithOp =
- Plus | Minus | Mul | Div | Mod | DecLeft | DecRight | And | Or | Xor
-and logicalOp = Inf | Sup | InfEq | SupEq | Eq | NotEq | AndLog | OrLog
-
-and constant =
- String of string
- | Char of string
- | Int of string
- | Float of string
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and base_fullType =
- Type of const_vol mcode option * typeC
- | DisjType of fullType list (* only after iso *)
- | OptType of fullType
- | UniqueType of fullType
-
-and base_typeC =
- BaseType of baseType * string mcode list (* Yoann style *)
- | SignedT of sign mcode * typeC option
- | Pointer of fullType * string mcode (* * *)
- | FunctionPointer of fullType *
- string mcode(* ( *)*string mcode(* * *)*string mcode(* ) *)*
- string mcode (* ( *)*parameter_list*string mcode(* ) *)
-
- (* used for the automatic managment of prototypes *)
- | FunctionType of bool (* true if all minus for dropping return type *) *
- fullType option *
- string mcode (* ( *) * parameter_list *
- string mcode (* ) *)
-
- | Array of fullType * string mcode (* [ *) *
- expression option * string mcode (* ] *)
- | EnumName of string mcode (*enum*) * ident (* name *)
- | StructUnionName of structUnion mcode * ident option (* name *)
- | StructUnionDef of fullType (* either StructUnionName or metavar *) *
- string mcode (* { *) * declaration dots * string mcode (* } *)
- | TypeName of string mcode
-
- | MetaType of meta_name mcode * keep_binding * inherited
-
-and fullType = base_fullType wrap
-and typeC = base_typeC wrap
-
-and baseType = VoidType | CharType | ShortType | IntType | DoubleType
- | FloatType | LongType | LongLongType
-
-and structUnion = Struct | Union
-
-and sign = Signed | Unsigned
-
-and const_vol = Const | Volatile
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and base_declaration =
- Init of storage mcode option * fullType * ident * string mcode (*=*) *
- initialiser * string mcode (*;*)
- | UnInit of storage mcode option * fullType * ident * string mcode (* ; *)
- | TyDecl of fullType * string mcode (* ; *)
- | MacroDecl of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *) * string mcode (* ; *)
- | Typedef of string mcode (*typedef*) * fullType *
- typeC (* either TypeName or metavar *) * string mcode (*;*)
- | DisjDecl of declaration list
- (* Ddots is for a structure declaration *)
- | Ddots of string mcode (* ... *) * declaration option (* whencode *)
-
- | MetaDecl of meta_name mcode * keep_binding * inherited
-
- | OptDecl of declaration
- | UniqueDecl of declaration
-
-and declaration = base_declaration wrap
-
-(* --------------------------------------------------------------------- *)
-(* Initializers *)
-
-and base_initialiser =
- MetaInit of meta_name mcode * keep_binding * inherited
- | InitExpr of expression
- | InitList of string mcode (*{*) * initialiser list * string mcode (*}*) *
- initialiser list (* whencode: elements that shouldn't appear in init *)
- | InitGccExt of
- designator list (* name *) * string mcode (*=*) *
- initialiser (* gccext: *)
- | InitGccName of ident (* name *) * string mcode (*:*) *
- initialiser
- | IComma of string mcode (* , *)
-
- | OptIni of initialiser
- | UniqueIni of initialiser
-
-and designator =
- DesignatorField of string mcode (* . *) * ident
- | DesignatorIndex of string mcode (* [ *) * expression * string mcode (* ] *)
- | DesignatorRange of
- string mcode (* [ *) * expression * string mcode (* ... *) *
- expression * string mcode (* ] *)
-
-and initialiser = base_initialiser wrap
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and base_parameterTypeDef =
- VoidParam of fullType
- | Param of fullType * ident option
-
- | MetaParam of meta_name mcode * keep_binding * inherited
- | MetaParamList of meta_name mcode * listlen option * keep_binding *
- inherited
-
- | PComma of string mcode
-
- | Pdots of string mcode (* ... *)
- | Pcircles of string mcode (* ooo *)
-
- | OptParam of parameterTypeDef
- | UniqueParam of parameterTypeDef
-
-and parameterTypeDef = base_parameterTypeDef wrap
-
-and parameter_list = parameterTypeDef dots
-
-(* --------------------------------------------------------------------- *)
-(* #define Parameters *)
-
-and base_define_param =
- DParam of ident
- | DPComma of string mcode
- | DPdots of string mcode (* ... *)
- | DPcircles of string mcode (* ooo *)
- | OptDParam of define_param
- | UniqueDParam of define_param
-
-and define_param = base_define_param wrap
-
-and base_define_parameters =
- NoParams (* not parameter list, not an empty one *)
- | DParams of string mcode(*( *) * define_param dots * string mcode(* )*)
-
-and define_parameters = base_define_parameters wrap
-
-(* --------------------------------------------------------------------- *)
-(* positions *)
-
-(* PER = keep bindings separate, ALL = collect them *)
-and meta_collect = PER | ALL
-
-and meta_pos =
- MetaPos of meta_name mcode * meta_name list *
- meta_collect * keep_binding * inherited
- | NoMetaPos
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-
-and storage = Static | Auto | Register | Extern
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and base_rule_elem =
- FunHeader of mcodekind (* before the function header *) *
- bool (* true if all minus, for dropping static, etc *) *
- fninfo list * ident (* name *) *
- string mcode (* ( *) * parameter_list *
- string mcode (* ) *)
- | Decl of mcodekind (* before the decl *) *
- bool (* true if all minus *) * declaration
-
- | SeqStart of string mcode (* { *)
- | SeqEnd of string mcode (* } *)
-
- | ExprStatement of expression * string mcode (*;*)
- | IfHeader of string mcode (* if *) * string mcode (* ( *) *
- expression * string mcode (* ) *)
- | Else of string mcode (* else *)
- | WhileHeader of string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *)
- | DoHeader of string mcode (* do *)
- | WhileTail of string mcode (* while *) * string mcode (* ( *) *
- expression * string mcode (* ) *) *
- string mcode (* ; *)
- | ForHeader of string mcode (* for *) * string mcode (* ( *) *
- expression option * string mcode (*;*) *
- expression option * string mcode (*;*) *
- expression option * string mcode (* ) *)
- | IteratorHeader of ident (* name *) * string mcode (* ( *) *
- expression dots * string mcode (* ) *)
- | SwitchHeader of string mcode (* switch *) * string mcode (* ( *) *
- expression * string mcode (* ) *)
- | Break of string mcode (* break *) * string mcode (* ; *)
- | Continue of string mcode (* continue *) * string mcode (* ; *)
- | Label of ident * string mcode (* : *)
- | Goto of string mcode (* goto *) * ident * string mcode (* ; *)
- | Return of string mcode (* return *) * string mcode (* ; *)
- | ReturnExpr of string mcode (* return *) * expression *
- string mcode (* ; *)
-
- | MetaRuleElem of meta_name mcode * keep_binding * inherited
- | MetaStmt of meta_name mcode * keep_binding * metaStmtInfo *
- inherited
- | MetaStmtList of meta_name mcode * keep_binding * inherited
-
- | Exp of expression (* matches a subterm *)
- | TopExp of expression (* for macros body, exp at top level,
- not subexp *)
- | Ty of fullType (* only at SP top level, matches a subterm *)
- | TopInit of initialiser (* only at top level *)
- | Include of string mcode (*#include*) * inc_file mcode (*file *)
- | DefineHeader of string mcode (* #define *) * ident (* name *) *
- define_parameters (*params*)
- | Case of string mcode (* case *) * expression * string mcode (*:*)
- | Default of string mcode (* default *) * string mcode (*:*)
- | DisjRuleElem of rule_elem list
-
-and fninfo =
- FStorage of storage mcode
- | FType of fullType
- | FInline of string mcode
- | FAttr of string mcode
-
-and metaStmtInfo =
- NotSequencible | SequencibleAfterDots of dots_whencode list | Sequencible
-
-and rule_elem = base_rule_elem wrap
-
-and base_statement =
- Seq of rule_elem (* { *) * statement dots *
- statement dots * rule_elem (* } *)
- | IfThen of rule_elem (* header *) * statement * end_info (* endif *)
- | IfThenElse of rule_elem (* header *) * statement *
- rule_elem (* else *) * statement * end_info (* endif *)
- | While of rule_elem (* header *) * statement * end_info (*endwhile*)
- | Do of rule_elem (* do *) * statement * rule_elem (* tail *)
- | For of rule_elem (* header *) * statement * end_info (*endfor*)
- | Iterator of rule_elem (* header *) * statement * end_info (*enditer*)
- | Switch of rule_elem (* header *) * rule_elem (* { *) *
- case_line list * rule_elem (* } *)
- | Atomic of rule_elem
- | Disj of statement dots list
- | Nest of statement dots *
- (statement dots,statement) whencode list * multi *
- dots_whencode list * dots_whencode list
- | FunDecl of rule_elem (* header *) * rule_elem (* { *) *
- statement dots * statement dots * rule_elem (* } *)
- | Define of rule_elem (* header *) * statement dots
- | Dots of string mcode (* ... *) *
- (statement dots,statement) whencode list *
- dots_whencode list * dots_whencode list
- | Circles of string mcode (* ooo *) *
- (statement dots,statement) whencode list *
- dots_whencode list * dots_whencode list
- | Stars of string mcode (* *** *) *
- (statement dots,statement) whencode list *
- dots_whencode list * dots_whencode list
- | OptStm of statement
- | UniqueStm of statement
-
-and ('a,'b) whencode =
- WhenNot of 'a
- | WhenAlways of 'b
- | WhenModifier of when_modifier
- | WhenNotTrue of rule_elem (* useful for fvs *)
- | WhenNotFalse of rule_elem
-
-and when_modifier =
- (* The following removes the shortest path constraint. It can be used
- with other when modifiers *)
- WhenAny
- (* The following removes the special consideration of error paths. It
- can be used with other when modifiers *)
- | WhenStrict
- | WhenForall
- | WhenExists
-
-(* only used with asttoctl *)
-and dots_whencode =
- WParen of rule_elem * meta_name (*pren_var*)
- | Other of statement
- | Other_dots of statement dots
-
-and statement = base_statement wrap
-
-and base_case_line =
- CaseLine of rule_elem (* case/default header *) * statement dots
- | OptCase of case_line
-
-and case_line = base_case_line wrap
-
-and inc_file =
- Local of inc_elem list
- | NonLocal of inc_elem list
-
-and inc_elem =
- IncPath of string
- | IncDots
-
-and base_top_level =
- DECL of statement
- | CODE of statement dots
- | FILEINFO of string mcode (* old file *) * string mcode (* new file *)
- | ERRORWORDS of expression list
-
-and top_level = base_top_level wrap
-
-and rulename =
- CocciRulename of string option * dependency *
- string list * string list * exists * bool
- | GeneratedRulename of string option * dependency *
- string list * string list * exists * bool
- | ScriptRulename of string * dependency
-
-and ruletype = Normal | Generated
-
-and rule =
- CocciRule of string (* name *) *
- (dependency * string list (* dropped isos *) * exists) * top_level list
- * bool list * ruletype
- | ScriptRule of string * dependency * (string * meta_name) list * string
-
-and dependency =
- Dep of string (* rule applies for the current binding *)
- | AntiDep of string (* rule doesn't apply for the current binding *)
- | EverDep of string (* rule applies for some binding *)
- | NeverDep of string (* rule never applies for any binding *)
- | AndDep of dependency * dependency
- | OrDep of dependency * dependency
- | NoDep
-
-and rule_with_metavars = metavar list * rule
-
-and anything =
- FullTypeTag of fullType
- | BaseTypeTag of baseType
- | StructUnionTag of structUnion
- | SignTag of sign
- | IdentTag of ident
- | ExpressionTag of expression
- | ConstantTag of constant
- | UnaryOpTag of unaryOp
- | AssignOpTag of assignOp
- | FixOpTag of fixOp
- | BinaryOpTag of binaryOp
- | ArithOpTag of arithOp
- | LogicalOpTag of logicalOp
- | DeclarationTag of declaration
- | InitTag of initialiser
- | StorageTag of storage
- | IncFileTag of inc_file
- | Rule_elemTag of rule_elem
- | StatementTag of statement
- | CaseLineTag of case_line
- | ConstVolTag of const_vol
- | Token of string * info option
- | Code of top_level
- | ExprDotsTag of expression dots
- | ParamDotsTag of parameterTypeDef dots
- | StmtDotsTag of statement dots
- | DeclDotsTag of declaration dots
- | TypeCTag of typeC
- | ParamTag of parameterTypeDef
- | SgrepStartTag of string
- | SgrepEndTag of string
-
-(* --------------------------------------------------------------------- *)
-
-and exists = Exists | Forall | ReverseForall | Undetermined
-
-(* --------------------------------------------------------------------- *)
-
-let mkToken x = Token (x,None)
-
-(* --------------------------------------------------------------------- *)
-
-let rewrap model x = {model with node = x}
-let rewrap_mcode (_,a,b,c) x = (x,a,b,c)
-let unwrap x = x.node
-let unwrap_mcode (x,_,_,_) = x
-let get_mcodekind (_,_,x,_) = x
-let get_line x = x.node_line
-let get_mcode_line (_,l,_,_) = l.line
-let get_fvs x = x.free_vars
-let set_fvs fvs x = {x with free_vars = fvs}
-let get_mfvs x = x.minus_free_vars
-let set_mfvs mfvs x = {x with minus_free_vars = mfvs}
-let get_fresh x = x.fresh_vars
-let get_inherited x = x.inherited
-let get_saved x = x.saved_witness
-let get_dots_bef_aft x = x.bef_aft
-let set_dots_bef_aft d x = {x with bef_aft = d}
-let get_pos x = x.pos_info
-let set_pos x pos = {x with pos_info = pos}
-let get_test_exp x = x.true_if_test_exp
-let set_test_exp x = {x with true_if_test_exp = true}
-let get_isos x = x.iso_info
-let set_isos x isos = {x with iso_info = isos}
-let get_pos_var (_,_,_,p) = p
-let set_pos_var vr (a,b,c,_) = (a,b,c,vr)
-let drop_pos (a,b,c,_) = (a,b,c,NoMetaPos)
-
-let get_wcfvs (whencode : ('a wrap, 'b wrap) whencode list) =
- Common.union_all
- (List.map
- (function
- WhenNot(a) -> get_fvs a
- | WhenAlways(a) -> get_fvs a
- | WhenModifier(_) -> []
- | WhenNotTrue(e) -> get_fvs e
- | WhenNotFalse(e) -> get_fvs e)
- whencode)
-
-(* --------------------------------------------------------------------- *)
-
-let get_meta_name = function
- MetaIdDecl(ar,nm) -> nm
- | MetaFreshIdDecl(ar,nm) -> nm
- | MetaTypeDecl(ar,nm) -> nm
- | MetaInitDecl(ar,nm) -> nm
- | MetaListlenDecl(nm) -> nm
- | MetaParamDecl(ar,nm) -> nm
- | MetaParamListDecl(ar,nm,nm1) -> nm
- | MetaConstDecl(ar,nm,ty) -> nm
- | MetaErrDecl(ar,nm) -> nm
- | MetaExpDecl(ar,nm,ty) -> nm
- | MetaIdExpDecl(ar,nm,ty) -> nm
- | MetaLocalIdExpDecl(ar,nm,ty) -> nm
- | MetaExpListDecl(ar,nm,nm1) -> nm
- | MetaStmDecl(ar,nm) -> nm
- | MetaStmListDecl(ar,nm) -> nm
- | MetaFuncDecl(ar,nm) -> nm
- | MetaLocalFuncDecl(ar,nm) -> nm
- | MetaPosDecl(ar,nm) -> nm
- | MetaDeclarerDecl(ar,nm) -> nm
- | MetaIteratorDecl(ar,nm) -> nm
-
-(* --------------------------------------------------------------------- *)
-
-let no_info = { line = 0; column = 0; strbef = []; straft = [] }
-
-let make_term x =
- {node = x;
- node_line = 0;
- free_vars = [];
- minus_free_vars = [];
- fresh_vars = [];
- inherited = [];
- saved_witness = [];
- bef_aft = NoDots;
- pos_info = None;
- true_if_test_exp = false;
- iso_info = [] }
-
-let make_meta_rule_elem s d (fvs,fresh,inh) =
- {(make_term
- (MetaRuleElem((("",s),no_info,d,NoMetaPos),Type_cocci.Unitary,false)))
- with free_vars = fvs; fresh_vars = fresh; inherited = inh}
-
-let make_meta_decl s d (fvs,fresh,inh) =
- {(make_term
- (MetaDecl((("",s),no_info,d,NoMetaPos),Type_cocci.Unitary,false))) with
- free_vars = fvs; fresh_vars = fresh; inherited = inh}
-
-let make_mcode x = (x,no_info,CONTEXT(NoPos,NOTHING),NoMetaPos)
-
-(* --------------------------------------------------------------------- *)
-
-let equal_pos x y = x = y
-
-(* --------------------------------------------------------------------- *)
-
-let undots x =
- match unwrap x with
- DOTS e -> e
- | CIRCLES e -> e
- | STARS e -> e
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* For minus fragment, checks that all of the identifier metavariables that
-are used are not declared as fresh, and check that all declared variables
-are used. For plus fragment, just check that the variables declared as
-fresh are used. What is the issue about error variables? (don't remember) *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module V0 = Visitor_ast0
-
-(* all fresh identifiers *)
-let fresh_table = (Hashtbl.create(50) : ((string * string), unit) Hashtbl.t)
-
-let warning s = Printf.fprintf stderr "warning: %s\n" s
-
-let promote name = (name,(),Ast0.default_info(),(),None)
-
-(* --------------------------------------------------------------------- *)
-
-let find_loop table name =
- let rec loop = function
- [] -> raise Not_found
- | x::xs -> (try Hashtbl.find x name with Not_found -> loop xs) in
- loop table
-
-let check_table table minus (name,_,info,_,_) =
- let rl = info.Ast0.line_start in
- if minus
- then
- (try (find_loop table name) := true
- with
- Not_found ->
- (try
- Hashtbl.find fresh_table name;
- let (_,name) = name in
- failwith
- (Printf.sprintf
- "%d: unexpected use of a fresh identifier %s" rl name)
- with Not_found -> ()))
- else (try (find_loop table name) := true with Not_found -> ())
-
-let get_opt fn = Common.do_option fn
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots fn d =
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> List.iter fn x
- | Ast0.CIRCLES(x) -> List.iter fn x
- | Ast0.STARS(x) -> List.iter fn x
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-type context = ID | FIELD | FN | GLOBAL
-
-(* heuristic for distinguishing ifdef variables from undeclared metavariables*)
-let is_ifdef name =
- String.length name > 2 && String.uppercase name = name
-
-let ident context old_metas table minus i =
- match Ast0.unwrap i with
- Ast0.Id((name,_,info,_,_) : string Ast0.mcode) ->
- let rl = info.Ast0.line_start in
- let err =
- if List.exists (function x -> x = name) old_metas
- && (minus || Ast0.get_mcodekind i = Ast0.PLUS)
- then
- begin
- warning
- (Printf.sprintf
- "line %d: %s, previously declared as a metavariable, is used as an identifier" rl name);
- true
- end
- else false in
- (match context with
- ID ->
- if not (is_ifdef name) && minus && not err(* warn only once per id *)
- then
- warning
- (Printf.sprintf "line %d: should %s be a metavariable?" rl name)
- | _ -> ())
- | Ast0.MetaId(name,_,_) -> check_table table minus name
- | Ast0.MetaFunc(name,_,_) -> check_table table minus name
- | Ast0.MetaLocalFunc(name,_,_) -> check_table table minus name
- | Ast0.OptIdent(_) | Ast0.UniqueIdent(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let rec expression context old_metas table minus e =
- match Ast0.unwrap e with
- Ast0.Ident(id) ->
- ident context old_metas table minus id
- | Ast0.FunCall(fn,lp,args,rp) ->
- expression FN old_metas table minus fn;
- dots (expression ID old_metas table minus) args
- | Ast0.Assignment(left,op,right,_) ->
- expression context old_metas table minus left;
- expression ID old_metas table minus right
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- expression ID old_metas table minus exp1;
- get_opt (expression ID old_metas table minus) exp2;
- expression ID old_metas table minus exp3
- | Ast0.Postfix(exp,op) ->
- expression ID old_metas table minus exp
- | Ast0.Infix(exp,op) ->
- expression ID old_metas table minus exp
- | Ast0.Unary(exp,op) ->
- expression ID old_metas table minus exp
- | Ast0.Binary(left,op,right) ->
- expression ID old_metas table minus left;
- expression ID old_metas table minus right
- | Ast0.Paren(lp,exp,rp) ->
- expression ID old_metas table minus exp
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- expression ID old_metas table minus exp1;
- expression ID old_metas table minus exp2
- | Ast0.RecordAccess(exp,pt,field) ->
- expression ID old_metas table minus exp;
- ident FIELD old_metas table minus field
- | Ast0.RecordPtAccess(exp,ar,field) ->
- expression ID old_metas table minus exp;
- ident FIELD old_metas table minus field
- | Ast0.Cast(lp,ty,rp,exp) ->
- typeC old_metas table minus ty; expression ID old_metas table minus exp
- | Ast0.SizeOfExpr(szf,exp) -> expression ID old_metas table minus exp
- | Ast0.SizeOfType(szf,lp,ty,rp) -> typeC old_metas table minus ty
- | Ast0.TypeExp(ty) -> typeC old_metas table minus ty
- | Ast0.MetaExpr(name,_,Some tys,_,_) ->
- List.iter
- (function x ->
- match get_type_name x with
- Some(ty) -> check_table table minus (promote ty)
- | None -> ())
- tys;
- check_table table minus name
- | Ast0.MetaExpr(name,_,_,_,_) | Ast0.MetaErr(name,_,_) ->
- check_table table minus name
- | Ast0.MetaExprList(name,None,_) ->
- check_table table minus name
- | Ast0.MetaExprList(name,Some lenname,_) ->
- check_table table minus name;
- check_table table minus lenname
- | Ast0.DisjExpr(_,exps,_,_) ->
- List.iter (expression ID old_metas table minus) exps
- | Ast0.NestExpr(_,exp_dots,_,w,_) ->
- dots (expression ID old_metas table minus) exp_dots;
- get_opt (expression ID old_metas table minus) w
- | Ast0.Edots(_,Some x) | Ast0.Ecircles(_,Some x) | Ast0.Estars(_,Some x) ->
- expression ID old_metas table minus x
- | _ -> () (* no metavariable subterms *)
-
-and get_type_name = function
- Type_cocci.ConstVol(_,ty) | Type_cocci.SignedT(_,Some ty)
- | Type_cocci.Pointer(ty)
- | Type_cocci.FunctionPointer(ty) | Type_cocci.Array(ty) -> get_type_name ty
- | Type_cocci.MetaType(nm,_,_) -> Some nm
- | _ -> None
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and typeC old_metas table minus t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) -> typeC old_metas table minus ty
- | Ast0.Signed(sgn,ty) ->
- get_opt (typeC old_metas table minus) ty
- | Ast0.Pointer(ty,star) -> typeC old_metas table minus ty
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- typeC old_metas table minus ty;
- parameter_list old_metas table minus params
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- get_opt (typeC old_metas table minus) ty;
- parameter_list old_metas table minus params
- | Ast0.Array(ty,lb,size,rb) ->
- typeC old_metas table minus ty;
- get_opt (expression ID old_metas table minus) size
- | Ast0.MetaType(name,_) ->
- check_table table minus name
- | Ast0.DisjType(_,types,_,_) ->
- List.iter (typeC old_metas table minus) types
- | Ast0.EnumName(en,id) -> ident GLOBAL old_metas table minus id
- | Ast0.StructUnionName(su,Some id) -> ident GLOBAL old_metas table minus id
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- typeC old_metas table minus ty;
- dots (declaration GLOBAL old_metas table minus) decls
- | Ast0.OptType(ty) | Ast0.UniqueType(ty) ->
- failwith "unexpected code"
- | _ -> () (* no metavariable subterms *)
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and declaration context old_metas table minus d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- (match Ast0.unwrap ini with
- Ast0.InitExpr exp ->
- typeC old_metas table minus ty;
- ident context old_metas table minus id;
- expression ID old_metas table minus exp
- | _ ->
- (*
- if minus
- then
- failwith "complex initializer specification not allowed in - code"
- else*)
- (typeC old_metas table minus ty;
- ident context old_metas table minus id;
- initialiser old_metas table minus ini))
- | Ast0.UnInit(stg,ty,id,sem) ->
- typeC old_metas table minus ty; ident context old_metas table minus id
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- ident GLOBAL old_metas table minus name;
- dots (expression ID old_metas table minus) args
- | Ast0.TyDecl(ty,sem) -> typeC old_metas table minus ty
- | Ast0.Typedef(stg,ty,id,sem) ->
- typeC old_metas table minus ty;
- typeC old_metas table minus id
- | Ast0.DisjDecl(_,decls,_,_) ->
- List.iter (declaration ID old_metas table minus) decls
- | Ast0.Ddots(_,Some x) -> declaration ID old_metas table minus x
- | Ast0.Ddots(_,None) -> ()
- | Ast0.OptDecl(_) | Ast0.UniqueDecl(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and initialiser old_metas table minus ini =
- match Ast0.unwrap ini with
- Ast0.InitExpr(exp) -> expression ID old_metas table minus exp
- | Ast0.InitList(lb,initlist,rb) ->
- dots (initialiser old_metas table minus) initlist
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- ident FIELD old_metas table minus name;
- initialiser old_metas table minus ini
- | Ast0.InitGccName(name,eq,ini) ->
- ident FIELD old_metas table minus name;
- initialiser old_metas table minus ini
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- expression ID old_metas table minus exp;
- initialiser old_metas table minus ini
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- expression ID old_metas table minus exp1;
- expression ID old_metas table minus exp2;
- initialiser old_metas table minus ini
- | Ast0.Idots(_,Some x) -> initialiser old_metas table minus x
- | Ast0.OptIni(_) | Ast0.UniqueIni(_) ->
- failwith "unexpected code"
- | _ -> () (* no metavariable subterms *)
-
-and initialiser_list old_metas table minus =
- dots (initialiser old_metas table minus)
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef old_metas table minus param =
- match Ast0.unwrap param with
- Ast0.Param(ty,id) ->
- get_opt (ident ID old_metas table minus) id;
- typeC old_metas table minus ty
- | Ast0.MetaParam(name,_) ->
- check_table table minus name
- | Ast0.MetaParamList(name,None,_) ->
- check_table table minus name
- | Ast0.MetaParamList(name,Some lenname,_) ->
- check_table table minus name;
- check_table table minus lenname
- | _ -> () (* no metavariable subterms *)
-
-and parameter_list old_metas table minus =
- dots (parameterTypeDef old_metas table minus)
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and statement old_metas table minus s =
- match Ast0.unwrap s with
- Ast0.Decl(_,decl) -> declaration ID old_metas table minus decl
- | Ast0.Seq(lbrace,body,rbrace) -> dots (statement old_metas table minus) body
- | Ast0.ExprStatement(exp,sem) -> expression ID old_metas table minus exp
- | Ast0.IfThen(iff,lp,exp,rp,branch,_) ->
- expression ID old_metas table minus exp;
- statement old_metas table minus branch
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,_) ->
- expression ID old_metas table minus exp;
- statement old_metas table minus branch1;
- statement old_metas table minus branch2
- | Ast0.While(wh,lp,exp,rp,body,_) ->
- expression ID old_metas table minus exp;
- statement old_metas table minus body
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- statement old_metas table minus body;
- expression ID old_metas table minus exp
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,_) ->
- get_opt (expression ID old_metas table minus) exp1;
- get_opt (expression ID old_metas table minus) exp2;
- get_opt (expression ID old_metas table minus) exp3;
- statement old_metas table minus body
- | Ast0.Iterator(nm,lp,args,rp,body,_) ->
- ident GLOBAL old_metas table minus nm;
- dots (expression ID old_metas table minus) args;
- statement old_metas table minus body
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- expression ID old_metas table minus exp;
- dots (case_line old_metas table minus) cases
- | Ast0.ReturnExpr(ret,exp,sem) -> expression ID old_metas table minus exp
- | Ast0.MetaStmt(name,_) -> check_table table minus name
- | Ast0.MetaStmtList(name,_) -> check_table table minus name
- | Ast0.Exp(exp) -> expression ID old_metas table minus exp
- | Ast0.TopExp(exp) -> expression ID old_metas table minus exp
- | Ast0.Ty(ty) -> typeC old_metas table minus ty
- | Ast0.TopInit(init) -> initialiser old_metas table minus init
- | Ast0.Disj(_,rule_elem_dots_list,_,_) ->
- List.iter (dots (statement old_metas table minus)) rule_elem_dots_list
- | Ast0.Nest(_,rule_elem_dots,_,w,_) ->
- dots (statement old_metas table minus) rule_elem_dots;
- List.iter (whencode (dots (statement old_metas table minus))
- (statement old_metas table minus)
- (expression ID old_metas table minus))
- w
- | Ast0.Dots(_,x) | Ast0.Circles(_,x) | Ast0.Stars(_,x) ->
- List.iter
- (whencode (dots (statement old_metas table minus))
- (statement old_metas table minus)
- (expression ID old_metas table minus)) x
- | Ast0.FunDecl(_,fi,name,lp,params,rp,lbrace,body,rbrace) ->
- ident FN old_metas table minus name;
- List.iter (fninfo old_metas table minus) fi;
- parameter_list old_metas table minus params;
- dots (statement old_metas table minus) body
- | Ast0.Include(inc,s) -> () (* no metavariables possible *)
- | Ast0.Define(def,id,_,body) ->
- ident GLOBAL old_metas table minus id;
- dots (statement old_metas table minus) body
- | Ast0.Goto(_,i,_) -> ident ID old_metas table minus i
- | _ -> () (* no metavariable subterms *)
-
-and fninfo old_metas table minus = function
- Ast0.FStorage(stg) -> ()
- | Ast0.FType(ty) -> typeC old_metas table minus ty
- | Ast0.FInline(inline) -> ()
- | Ast0.FAttr(attr) -> ()
-
-and whencode notfn alwaysfn expression = function
- Ast0.WhenNot a -> notfn a
- | Ast0.WhenAlways a -> alwaysfn a
- | Ast0.WhenModifier(_) -> ()
- | Ast0.WhenNotTrue a -> expression a
- | Ast0.WhenNotFalse a -> expression a
-
-and case_line old_metas table minus c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- dots (statement old_metas table minus) code
- | Ast0.Case(case,exp,colon,code) ->
- dots (statement old_metas table minus) code
- | Ast0.OptCase(case) -> failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Rules *)
-
-let top_level old_metas table minus t =
- match Ast0.unwrap t with
- Ast0.DECL(stmt) -> statement old_metas table minus stmt
- | Ast0.CODE(stmt_dots) -> dots (statement old_metas table minus) stmt_dots
- | Ast0.ERRORWORDS(exps) ->
- List.iter (expression FN old_metas table minus) exps
- | _ -> () (* no metavariables possible *)
-
-let rule old_metas table minus rules =
- List.iter (top_level old_metas table minus) rules
-
-(* --------------------------------------------------------------------- *)
-
-let positions table rules =
- let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,constraints,_) ->
- let pos = Ast0.unwrap_mcode name in
- (find_loop table pos) := true
- | _ -> () in
- let option_default = () in
- let bind x y = () in
- let donothing r k e = k e in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
-
- List.iter fn.V0.combiner_top_level rules
-
-let dup_positions rules =
- let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,constraints,_) ->
- let pos = Ast0.unwrap_mcode name in [pos]
- | _ -> [] in
- let option_default = [] in
- let bind x y = x@y in
-
- (* Case for everything that has a disj.
- Note, no positions on ( | ) of a disjunction, so no need to recurse on
- these. *)
-
- let expression r k e =
- match Ast0.unwrap e with
- Ast0.DisjExpr(_,explist,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_expression explist)
- | _ -> k e in
-
- let typeC r k e = (* not sure relevent because "only after iso" *)
- match Ast0.unwrap e with
- Ast0.DisjType(_,types,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_typeC types)
- | _ -> k e in
-
- let declaration r k e =
- match Ast0.unwrap e with
- Ast0.DisjDecl(_,decls,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_declaration decls)
- | _ -> k e in
-
- let statement r k e =
- match Ast0.unwrap e with
- Ast0.Disj(_,stmts,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_statement_dots stmts)
- | _ -> k e in
-
- let donothing r k e = k e in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing expression typeC donothing donothing declaration statement
- donothing donothing in
-
- let res =
- List.sort compare
- (List.fold_left Common.union_set option_default
- (List.map fn.V0.combiner_top_level rules)) in
- let rec loop = function
- [] | [_] -> ()
- | ((rule,name) as x)::y::_ when x = y ->
- failwith (Printf.sprintf "duplicate use of %s.%s" rule name)
- | _::xs -> loop xs in
- loop res
-
-(* --------------------------------------------------------------------- *)
-
-let make_table l =
- let table =
- (Hashtbl.create(List.length l) :
- ((string * string), bool ref) Hashtbl.t) in
- List.iter
- (function x -> Hashtbl.add table (Ast.get_meta_name x) (ref false)) l;
- table
-
-let add_to_fresh_table l =
- List.iter
- (function x ->
- let name = Ast.get_meta_name x in Hashtbl.replace fresh_table name ())
- l
-
-let check_all_marked rname err table after_err =
- Hashtbl.iter
- (function name ->
- function (cell) ->
- if not (!cell)
- then
- let (_,name) = name in
- warning
- (Printf.sprintf "%s: %s %s not used %s" rname err name after_err))
- table
-
-let check_meta rname old_metas inherited_metavars metavars minus plus =
- let old_metas =
- List.map (function (_,x) -> x) (List.map Ast.get_meta_name old_metas) in
- let (fresh,other) =
- List.partition (function Ast.MetaFreshIdDecl(_,_) -> true | _ -> false)
- metavars in
- let (err,other) =
- List.partition (function Ast.MetaErrDecl(_,_) -> true | _ -> false)
- other in
- let (ierr,iother) =
- List.partition (function Ast.MetaErrDecl(_,_) -> true | _ -> false)
- inherited_metavars in
- let fresh_table = make_table fresh in
- let err_table = make_table (err@ierr) in
- let other_table = make_table other in
- let iother_table = make_table iother in
- add_to_fresh_table fresh;
- rule old_metas [iother_table;other_table;err_table] true minus;
- positions [iother_table;other_table] minus;
- dup_positions minus;
- check_all_marked rname "metavariable" other_table "in the - or context code";
- rule old_metas [iother_table;fresh_table;err_table] false plus;
- check_all_marked rname "inherited metavariable" iother_table
- "in the -, +, or context code";
- check_all_marked rname "metavariable" fresh_table "in the + code";
- check_all_marked rname "error metavariable" err_table ""
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* For minus fragment, checks that all of the identifier metavariables that
-are used are not declared as fresh, and check that all declared variables
-are used. For plus fragment, just check that the variables declared as
-fresh are used. What is the issue about error variables? (don't remember) *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module V0 = Visitor_ast0
-
-(* all fresh identifiers *)
-let fresh_table = (Hashtbl.create(50) : ((string * string), unit) Hashtbl.t)
-
-let warning s = Printf.fprintf stderr "warning: %s\n" s
-
-let promote name = (name,(),Ast0.default_info(),(),None)
-
-(* --------------------------------------------------------------------- *)
-
-let find_loop table name =
- let rec loop = function
- [] -> raise Not_found
- | x::xs -> (try Hashtbl.find x name with Not_found -> loop xs) in
- loop table
-
-let check_table table minus (name,_,info,_,_) =
- let rl = info.Ast0.line_start in
- if minus
- then
- (try (find_loop table name) := true
- with
- Not_found ->
- (try
- Hashtbl.find fresh_table name;
- let (_,name) = name in
- failwith
- (Printf.sprintf
- "%d: unexpected use of a fresh identifier %s" rl name)
- with Not_found -> ()))
- else (try (find_loop table name) := true with Not_found -> ())
-
-let get_opt fn = Common.do_option fn
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots fn d =
- match Ast0.unwrap d with
- Ast0.DOTS(x) -> List.iter fn x
- | Ast0.CIRCLES(x) -> List.iter fn x
- | Ast0.STARS(x) -> List.iter fn x
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-type context = ID | FIELD | FN | GLOBAL
-
-(* heuristic for distinguishing ifdef variables from undeclared metavariables*)
-let is_ifdef name =
- String.length name > 2 && String.uppercase name = name
-
-let ident context old_metas table minus i =
- match Ast0.unwrap i with
- Ast0.Id((name,_,info,_,_) : string Ast0.mcode) ->
- let rl = info.Ast0.line_start in
- let err =
- if List.exists (function x -> x = name) old_metas
- && (minus || Ast0.get_mcodekind i = Ast0.PLUS)
- then
- begin
- warning
- (Printf.sprintf
- "line %d: %s, previously declared as a metavariable, is used as an identifier" rl name);
- true
- end
- else false in
- (match context with
- ID ->
- if not (is_ifdef name) && minus && not err(* warn only once per id *)
- then
- warning
- (Printf.sprintf "line %d: should %s be a metavariable?" rl name)
- | _ -> ())
- | Ast0.MetaId(name,_,_) -> check_table table minus name
- | Ast0.MetaFunc(name,_,_) -> check_table table minus name
- | Ast0.MetaLocalFunc(name,_,_) -> check_table table minus name
- | Ast0.OptIdent(_) | Ast0.UniqueIdent(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let rec expression context old_metas table minus e =
- match Ast0.unwrap e with
- Ast0.Ident(id) ->
- ident context old_metas table minus id
- | Ast0.FunCall(fn,lp,args,rp) ->
- expression FN old_metas table minus fn;
- dots (expression ID old_metas table minus) args
- | Ast0.Assignment(left,op,right,_) ->
- expression context old_metas table minus left;
- expression ID old_metas table minus right
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- expression ID old_metas table minus exp1;
- get_opt (expression ID old_metas table minus) exp2;
- expression ID old_metas table minus exp3
- | Ast0.Postfix(exp,op) ->
- expression ID old_metas table minus exp
- | Ast0.Infix(exp,op) ->
- expression ID old_metas table minus exp
- | Ast0.Unary(exp,op) ->
- expression ID old_metas table minus exp
- | Ast0.Binary(left,op,right) ->
- expression ID old_metas table minus left;
- expression ID old_metas table minus right
- | Ast0.Paren(lp,exp,rp) ->
- expression ID old_metas table minus exp
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- expression ID old_metas table minus exp1;
- expression ID old_metas table minus exp2
- | Ast0.RecordAccess(exp,pt,field) ->
- expression ID old_metas table minus exp;
- ident FIELD old_metas table minus field
- | Ast0.RecordPtAccess(exp,ar,field) ->
- expression ID old_metas table minus exp;
- ident FIELD old_metas table minus field
- | Ast0.Cast(lp,ty,rp,exp) ->
- typeC old_metas table minus ty; expression ID old_metas table minus exp
- | Ast0.SizeOfExpr(szf,exp) -> expression ID old_metas table minus exp
- | Ast0.SizeOfType(szf,lp,ty,rp) -> typeC old_metas table minus ty
- | Ast0.TypeExp(ty) -> typeC old_metas table minus ty
- | Ast0.MetaExpr(name,_,Some tys,_,_) ->
- List.iter
- (function x ->
- match get_type_name x with
- Some(ty) -> check_table table minus (promote ty)
- | None -> ())
- tys;
- check_table table minus name
- | Ast0.MetaExpr(name,_,_,_,_) | Ast0.MetaErr(name,_,_) ->
- check_table table minus name
- | Ast0.MetaExprList(name,None,_) ->
- check_table table minus name
- | Ast0.MetaExprList(name,Some lenname,_) ->
- check_table table minus name;
- check_table table minus lenname
- | Ast0.DisjExpr(_,exps,_,_) ->
- List.iter (expression ID old_metas table minus) exps
- | Ast0.NestExpr(_,exp_dots,_,w,_) ->
- dots (expression ID old_metas table minus) exp_dots;
- get_opt (expression ID old_metas table minus) w
- | Ast0.Edots(_,Some x) | Ast0.Ecircles(_,Some x) | Ast0.Estars(_,Some x) ->
- expression ID old_metas table minus x
- | _ -> () (* no metavariable subterms *)
-
-and get_type_name = function
- Type_cocci.ConstVol(_,ty) | Type_cocci.SignedT(_,Some ty)
- | Type_cocci.Pointer(ty)
- | Type_cocci.FunctionPointer(ty) | Type_cocci.Array(ty) -> get_type_name ty
- | Type_cocci.MetaType(nm,_,_) -> Some nm
- | _ -> None
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and typeC old_metas table minus t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) -> typeC old_metas table minus ty
- | Ast0.Signed(sgn,ty) ->
- get_opt (typeC old_metas table minus) ty
- | Ast0.Pointer(ty,star) -> typeC old_metas table minus ty
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- typeC old_metas table minus ty;
- parameter_list old_metas table minus params
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- get_opt (typeC old_metas table minus) ty;
- parameter_list old_metas table minus params
- | Ast0.Array(ty,lb,size,rb) ->
- typeC old_metas table minus ty;
- get_opt (expression ID old_metas table minus) size
- | Ast0.MetaType(name,_) ->
- check_table table minus name
- | Ast0.DisjType(_,types,_,_) ->
- List.iter (typeC old_metas table minus) types
- | Ast0.EnumName(en,id) -> ident GLOBAL old_metas table minus id
- | Ast0.StructUnionName(su,Some id) -> ident GLOBAL old_metas table minus id
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- typeC old_metas table minus ty;
- dots (declaration GLOBAL old_metas table minus) decls
- | Ast0.OptType(ty) | Ast0.UniqueType(ty) ->
- failwith "unexpected code"
- | _ -> () (* no metavariable subterms *)
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and declaration context old_metas table minus d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- (match Ast0.unwrap ini with
- Ast0.InitExpr exp ->
- typeC old_metas table minus ty;
- ident context old_metas table minus id;
- expression ID old_metas table minus exp
- | _ ->
- (*
- if minus
- then
- failwith "complex initializer specification not allowed in - code"
- else*)
- (typeC old_metas table minus ty;
- ident context old_metas table minus id;
- initialiser old_metas table minus ini))
- | Ast0.UnInit(stg,ty,id,sem) ->
- typeC old_metas table minus ty; ident context old_metas table minus id
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- ident GLOBAL old_metas table minus name;
- dots (expression ID old_metas table minus) args
- | Ast0.TyDecl(ty,sem) -> typeC old_metas table minus ty
- | Ast0.Typedef(stg,ty,id,sem) ->
- typeC old_metas table minus ty;
- typeC old_metas table minus id
- | Ast0.DisjDecl(_,decls,_,_) ->
- List.iter (declaration ID old_metas table minus) decls
- | Ast0.Ddots(_,Some x) -> declaration ID old_metas table minus x
- | Ast0.Ddots(_,None) -> ()
- | Ast0.OptDecl(_) | Ast0.UniqueDecl(_) ->
- failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and initialiser old_metas table minus ini =
- match Ast0.unwrap ini with
- Ast0.MetaInit(name,_) ->
- check_table table minus name
- | Ast0.InitExpr(exp) -> expression ID old_metas table minus exp
- | Ast0.InitList(lb,initlist,rb) ->
- dots (initialiser old_metas table minus) initlist
- | Ast0.InitGccExt(designators,eq,ini) ->
- List.iter (designator old_metas table minus) designators;
- initialiser old_metas table minus ini
- | Ast0.InitGccName(name,eq,ini) ->
- ident FIELD old_metas table minus name;
- initialiser old_metas table minus ini
- | Ast0.Idots(_,Some x) -> initialiser old_metas table minus x
- | Ast0.OptIni(_) | Ast0.UniqueIni(_) ->
- failwith "unexpected code"
- | _ -> () (* no metavariable subterms *)
-
-and designator old_metas table minus = function
- Ast0.DesignatorField(dot,id) ->
- ident FIELD old_metas table minus id
- | Ast0.DesignatorIndex(lb,exp,rb) ->
- expression ID old_metas table minus exp
- | Ast0.DesignatorRange(lb,min,dots,max,rb) ->
- expression ID old_metas table minus min;
- expression ID old_metas table minus max
-
-and initialiser_list old_metas table minus =
- dots (initialiser old_metas table minus)
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef old_metas table minus param =
- match Ast0.unwrap param with
- Ast0.Param(ty,id) ->
- get_opt (ident ID old_metas table minus) id;
- typeC old_metas table minus ty
- | Ast0.MetaParam(name,_) ->
- check_table table minus name
- | Ast0.MetaParamList(name,None,_) ->
- check_table table minus name
- | Ast0.MetaParamList(name,Some lenname,_) ->
- check_table table minus name;
- check_table table minus lenname
- | _ -> () (* no metavariable subterms *)
-
-and parameter_list old_metas table minus =
- dots (parameterTypeDef old_metas table minus)
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and statement old_metas table minus s =
- match Ast0.unwrap s with
- Ast0.Decl(_,decl) -> declaration ID old_metas table minus decl
- | Ast0.Seq(lbrace,body,rbrace) -> dots (statement old_metas table minus) body
- | Ast0.ExprStatement(exp,sem) -> expression ID old_metas table minus exp
- | Ast0.IfThen(iff,lp,exp,rp,branch,_) ->
- expression ID old_metas table minus exp;
- statement old_metas table minus branch
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,_) ->
- expression ID old_metas table minus exp;
- statement old_metas table minus branch1;
- statement old_metas table minus branch2
- | Ast0.While(wh,lp,exp,rp,body,_) ->
- expression ID old_metas table minus exp;
- statement old_metas table minus body
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- statement old_metas table minus body;
- expression ID old_metas table minus exp
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,_) ->
- get_opt (expression ID old_metas table minus) exp1;
- get_opt (expression ID old_metas table minus) exp2;
- get_opt (expression ID old_metas table minus) exp3;
- statement old_metas table minus body
- | Ast0.Iterator(nm,lp,args,rp,body,_) ->
- ident GLOBAL old_metas table minus nm;
- dots (expression ID old_metas table minus) args;
- statement old_metas table minus body
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- expression ID old_metas table minus exp;
- dots (case_line old_metas table minus) cases
- | Ast0.ReturnExpr(ret,exp,sem) -> expression ID old_metas table minus exp
- | Ast0.MetaStmt(name,_) -> check_table table minus name
- | Ast0.MetaStmtList(name,_) -> check_table table minus name
- | Ast0.Exp(exp) -> expression ID old_metas table minus exp
- | Ast0.TopExp(exp) -> expression ID old_metas table minus exp
- | Ast0.Ty(ty) -> typeC old_metas table minus ty
- | Ast0.TopInit(init) -> initialiser old_metas table minus init
- | Ast0.Disj(_,rule_elem_dots_list,_,_) ->
- List.iter (dots (statement old_metas table minus)) rule_elem_dots_list
- | Ast0.Nest(_,rule_elem_dots,_,w,_) ->
- dots (statement old_metas table minus) rule_elem_dots;
- List.iter (whencode (dots (statement old_metas table minus))
- (statement old_metas table minus)
- (expression ID old_metas table minus))
- w
- | Ast0.Dots(_,x) | Ast0.Circles(_,x) | Ast0.Stars(_,x) ->
- List.iter
- (whencode (dots (statement old_metas table minus))
- (statement old_metas table minus)
- (expression ID old_metas table minus)) x
- | Ast0.FunDecl(_,fi,name,lp,params,rp,lbrace,body,rbrace) ->
- ident FN old_metas table minus name;
- List.iter (fninfo old_metas table minus) fi;
- parameter_list old_metas table minus params;
- dots (statement old_metas table minus) body
- | Ast0.Include(inc,s) -> () (* no metavariables possible *)
- | Ast0.Define(def,id,_,body) ->
- ident GLOBAL old_metas table minus id;
- dots (statement old_metas table minus) body
- | Ast0.Goto(_,i,_) -> ident ID old_metas table minus i
- | _ -> () (* no metavariable subterms *)
-
-and fninfo old_metas table minus = function
- Ast0.FStorage(stg) -> ()
- | Ast0.FType(ty) -> typeC old_metas table minus ty
- | Ast0.FInline(inline) -> ()
- | Ast0.FAttr(attr) -> ()
-
-and whencode notfn alwaysfn expression = function
- Ast0.WhenNot a -> notfn a
- | Ast0.WhenAlways a -> alwaysfn a
- | Ast0.WhenModifier(_) -> ()
- | Ast0.WhenNotTrue a -> expression a
- | Ast0.WhenNotFalse a -> expression a
-
-and case_line old_metas table minus c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- dots (statement old_metas table minus) code
- | Ast0.Case(case,exp,colon,code) ->
- dots (statement old_metas table minus) code
- | Ast0.OptCase(case) -> failwith "unexpected code"
-
-(* --------------------------------------------------------------------- *)
-(* Rules *)
-
-let top_level old_metas table minus t =
- match Ast0.unwrap t with
- Ast0.DECL(stmt) -> statement old_metas table minus stmt
- | Ast0.CODE(stmt_dots) -> dots (statement old_metas table minus) stmt_dots
- | Ast0.ERRORWORDS(exps) ->
- List.iter (expression FN old_metas table minus) exps
- | _ -> () (* no metavariables possible *)
-
-let rule old_metas table minus rules =
- List.iter (top_level old_metas table minus) rules
-
-(* --------------------------------------------------------------------- *)
-
-let positions table rules =
- let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,constraints,_) ->
- let pos = Ast0.unwrap_mcode name in
- (find_loop table pos) := true
- | _ -> () in
- let option_default = () in
- let bind x y = () in
- let donothing r k e = k e in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
-
- List.iter fn.V0.combiner_top_level rules
-
-let dup_positions rules =
- let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,constraints,_) ->
- let pos = Ast0.unwrap_mcode name in [pos]
- | _ -> [] in
- let option_default = [] in
- let bind x y = x@y in
-
- (* Case for everything that has a disj.
- Note, no positions on ( | ) of a disjunction, so no need to recurse on
- these. *)
-
- let expression r k e =
- match Ast0.unwrap e with
- Ast0.DisjExpr(_,explist,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_expression explist)
- | _ -> k e in
-
- let typeC r k e = (* not sure relevent because "only after iso" *)
- match Ast0.unwrap e with
- Ast0.DisjType(_,types,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_typeC types)
- | _ -> k e in
-
- let declaration r k e =
- match Ast0.unwrap e with
- Ast0.DisjDecl(_,decls,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_declaration decls)
- | _ -> k e in
-
- let statement r k e =
- match Ast0.unwrap e with
- Ast0.Disj(_,stmts,_,_) ->
- List.fold_left Common.union_set option_default
- (List.map r.V0.combiner_statement_dots stmts)
- | _ -> k e in
-
- let donothing r k e = k e in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing expression typeC donothing donothing declaration statement
- donothing donothing in
-
- let res =
- List.sort compare
- (List.fold_left Common.union_set option_default
- (List.map fn.V0.combiner_top_level rules)) in
- let rec loop = function
- [] | [_] -> ()
- | ((rule,name) as x)::y::_ when x = y ->
- failwith (Printf.sprintf "duplicate use of %s.%s" rule name)
- | _::xs -> loop xs in
- loop res
-
-(* --------------------------------------------------------------------- *)
-
-let make_table l =
- let table =
- (Hashtbl.create(List.length l) :
- ((string * string), bool ref) Hashtbl.t) in
- List.iter
- (function x -> Hashtbl.add table (Ast.get_meta_name x) (ref false)) l;
- table
-
-let add_to_fresh_table l =
- List.iter
- (function x ->
- let name = Ast.get_meta_name x in Hashtbl.replace fresh_table name ())
- l
-
-let check_all_marked rname err table after_err =
- Hashtbl.iter
- (function name ->
- function (cell) ->
- if not (!cell)
- then
- let (_,name) = name in
- warning
- (Printf.sprintf "%s: %s %s not used %s" rname err name after_err))
- table
-
-let check_meta rname old_metas inherited_metavars metavars minus plus =
- let old_metas =
- List.map (function (_,x) -> x) (List.map Ast.get_meta_name old_metas) in
- let (fresh,other) =
- List.partition (function Ast.MetaFreshIdDecl(_,_) -> true | _ -> false)
- metavars in
- let (err,other) =
- List.partition (function Ast.MetaErrDecl(_,_) -> true | _ -> false)
- other in
- let (ierr,iother) =
- List.partition (function Ast.MetaErrDecl(_,_) -> true | _ -> false)
- inherited_metavars in
- let fresh_table = make_table fresh in
- let err_table = make_table (err@ierr) in
- let other_table = make_table other in
- let iother_table = make_table iother in
- add_to_fresh_table fresh;
- rule old_metas [iother_table;other_table;err_table] true minus;
- positions [iother_table;other_table] minus;
- dup_positions minus;
- check_all_marked rname "metavariable" other_table "in the - or context code";
- rule old_metas [iother_table;fresh_table;err_table] false plus;
- check_all_marked rname "inherited metavariable" iother_table
- "in the -, +, or context code";
- check_all_marked rname "metavariable" fresh_table "in the + code";
- check_all_marked rname "error metavariable" err_table ""
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Computes starting and ending logical lines for statements and
-expressions. every node gets an index as well. *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Result *)
-
-let mkres x e left right =
- let lstart = Ast0.get_info left in
- let lend = Ast0.get_info right in
- let info =
- { Ast0.line_start = lstart.Ast0.line_start;
- Ast0.line_end = lend.Ast0.line_end;
- Ast0.logical_start = lstart.Ast0.logical_start;
- Ast0.logical_end = lend.Ast0.logical_end;
- Ast0.attachable_start = lstart.Ast0.attachable_start;
- Ast0.attachable_end = lend.Ast0.attachable_end;
- Ast0.mcode_start = lstart.Ast0.mcode_start;
- Ast0.mcode_end = lend.Ast0.mcode_end;
- Ast0.column = lstart.Ast0.column;
- Ast0.offset = lstart.Ast0.offset;
- (* only for tokens, not inherited upwards *)
- Ast0.strings_before = []; Ast0.strings_after = []} in
- {x with Ast0.node = e; Ast0.info = info}
-
-let mkmultires x e left right (astart,start_mcodes) (aend,end_mcodes) =
- let lstart = Ast0.get_info left in
- let lend = Ast0.get_info right in
- let info =
- { Ast0.line_start = lstart.Ast0.line_start;
- Ast0.line_end = lend.Ast0.line_end;
- Ast0.logical_start = lstart.Ast0.logical_start;
- Ast0.logical_end = lend.Ast0.logical_end;
- Ast0.attachable_start = astart;
- Ast0.attachable_end = aend;
- Ast0.mcode_start = start_mcodes;
- Ast0.mcode_end = end_mcodes;
- Ast0.column = lstart.Ast0.column;
- Ast0.offset = lstart.Ast0.offset;
- (* only for tokens, not inherited upwards *)
- Ast0.strings_before = []; Ast0.strings_after = [] } in
- {x with Ast0.node = e; Ast0.info = info}
-
-(* --------------------------------------------------------------------- *)
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Mcode *)
-
-let promote_mcode (_,_,info,mcodekind,_) =
- let new_info =
- {info with
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind]} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-let promote_mcode_plus_one (_,_,info,mcodekind,_) =
- let new_info =
- {info with
- Ast0.line_start = info.Ast0.line_start + 1;
- Ast0.logical_start = info.Ast0.logical_start + 1;
- Ast0.line_end = info.Ast0.line_end + 1;
- Ast0.logical_end = info.Ast0.logical_end + 1;
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind]} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-let promote_to_statement stm mcodekind =
- let info = Ast0.get_info stm in
- let new_info =
- {info with
- Ast0.logical_start = info.Ast0.logical_end;
- Ast0.line_start = info.Ast0.line_end;
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind];
- Ast0.attachable_start = true; Ast0.attachable_end = true} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-let promote_to_statement_start stm mcodekind =
- let info = Ast0.get_info stm in
- let new_info =
- {info with
- Ast0.logical_end = info.Ast0.logical_start;
- Ast0.line_end = info.Ast0.line_start;
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind];
- Ast0.attachable_start = true; Ast0.attachable_end = true} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-(* mcode is good by default *)
-let bad_mcode (t,a,info,mcodekind,pos) =
- let new_info =
- {info with Ast0.attachable_start = false; Ast0.attachable_end = false} in
- (t,a,new_info,mcodekind,pos)
-
-let get_all_start_info l =
- (List.for_all (function x -> (Ast0.get_info x).Ast0.attachable_start) l,
- List.concat (List.map (function x -> (Ast0.get_info x).Ast0.mcode_start) l))
-
-let get_all_end_info l =
- (List.for_all (function x -> (Ast0.get_info x).Ast0.attachable_end) l,
- List.concat (List.map (function x -> (Ast0.get_info x).Ast0.mcode_end) l))
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-(* for the logline classification and the mcode field, on both sides, skip
-over initial minus dots, as they don't contribute anything *)
-let dot_list is_dots fn = function
- [] -> failwith "dots should not be empty"
- | l ->
- let get_node l fn =
- let first = List.hd l in
- let chosen =
- match (is_dots first, l) with (true,_::x::_) -> x | _ -> first in
- (* get the logline decorator and the mcodekind of the chosen node *)
- fn (Ast0.get_info chosen) in
- let forward = List.map fn l in
- let backward = List.rev forward in
- let (first_attachable,first_mcode) =
- get_node forward
- (function x -> (x.Ast0.attachable_start,x.Ast0.mcode_start)) in
- let (last_attachable,last_mcode) =
- get_node backward
- (function x -> (x.Ast0.attachable_end,x.Ast0.mcode_end)) in
- let first = List.hd forward in
- let last = List.hd backward in
- let first_info =
- { (Ast0.get_info first) with
- Ast0.attachable_start = first_attachable;
- Ast0.mcode_start = first_mcode } in
- let last_info =
- { (Ast0.get_info last) with
- Ast0.attachable_end = last_attachable;
- Ast0.mcode_end = last_mcode } in
- let first = Ast0.set_info first first_info in
- let last = Ast0.set_info last last_info in
- (forward,first,last)
-
-let dots is_dots prev fn d =
- match (prev,Ast0.unwrap d) with
- (Some prev,Ast0.DOTS([])) ->
- mkres d (Ast0.DOTS []) prev prev
- | (None,Ast0.DOTS([])) ->
- Ast0.set_info d
- {(Ast0.get_info d)
- with Ast0.attachable_start = false; Ast0.attachable_end = false}
- | (_,Ast0.DOTS(x)) ->
- let (l,lstart,lend) = dot_list is_dots fn x in
- mkres d (Ast0.DOTS l) lstart lend
- | (_,Ast0.CIRCLES(x)) ->
- let (l,lstart,lend) = dot_list is_dots fn x in
- mkres d (Ast0.CIRCLES l) lstart lend
- | (_,Ast0.STARS(x)) ->
- let (l,lstart,lend) = dot_list is_dots fn x in
- mkres d (Ast0.STARS l) lstart lend
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec ident i =
- match Ast0.unwrap i with
- Ast0.Id(name) as ui ->
- let name = promote_mcode name in mkres i ui name name
- | Ast0.MetaId(name,_,_)
- | Ast0.MetaFunc(name,_,_) | Ast0.MetaLocalFunc(name,_,_) as ui ->
- let name = promote_mcode name in mkres i ui name name
- | Ast0.OptIdent(id) ->
- let id = ident id in mkres i (Ast0.OptIdent(id)) id id
- | Ast0.UniqueIdent(id) ->
- let id = ident id in mkres i (Ast0.UniqueIdent(id)) id id
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let is_exp_dots e =
- match Ast0.unwrap e with
- Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> true
- | _ -> false
-
-let rec expression e =
- match Ast0.unwrap e with
- Ast0.Ident(id) ->
- let id = ident id in
- mkres e (Ast0.Ident(id)) id id
- | Ast0.Constant(const) as ue ->
- let ln = promote_mcode const in
- mkres e ue ln ln
- | Ast0.FunCall(fn,lp,args,rp) ->
- let fn = expression fn in
- let args = dots is_exp_dots (Some(promote_mcode lp)) expression args in
- mkres e (Ast0.FunCall(fn,lp,args,rp)) fn (promote_mcode rp)
- | Ast0.Assignment(left,op,right,simple) ->
- let left = expression left in
- let right = expression right in
- mkres e (Ast0.Assignment(left,op,right,simple)) left right
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- let exp1 = expression exp1 in
- let exp2 = get_option expression exp2 in
- let exp3 = expression exp3 in
- mkres e (Ast0.CondExpr(exp1,why,exp2,colon,exp3)) exp1 exp3
- | Ast0.Postfix(exp,op) ->
- let exp = expression exp in
- mkres e (Ast0.Postfix(exp,op)) exp (promote_mcode op)
- | Ast0.Infix(exp,op) ->
- let exp = expression exp in
- mkres e (Ast0.Infix(exp,op)) (promote_mcode op) exp
- | Ast0.Unary(exp,op) ->
- let exp = expression exp in
- mkres e (Ast0.Unary(exp,op)) (promote_mcode op) exp
- | Ast0.Binary(left,op,right) ->
- let left = expression left in
- let right = expression right in
- mkres e (Ast0.Binary(left,op,right)) left right
- | Ast0.Nested(left,op,right) ->
- let left = expression left in
- let right = expression right in
- mkres e (Ast0.Nested(left,op,right)) left right
- | Ast0.Paren(lp,exp,rp) ->
- mkres e (Ast0.Paren(lp,expression exp,rp))
- (promote_mcode lp) (promote_mcode rp)
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- let exp1 = expression exp1 in
- let exp2 = expression exp2 in
- mkres e (Ast0.ArrayAccess(exp1,lb,exp2,rb)) exp1 (promote_mcode rb)
- | Ast0.RecordAccess(exp,pt,field) ->
- let exp = expression exp in
- let field = ident field in
- mkres e (Ast0.RecordAccess(exp,pt,field)) exp field
- | Ast0.RecordPtAccess(exp,ar,field) ->
- let exp = expression exp in
- let field = ident field in
- mkres e (Ast0.RecordPtAccess(exp,ar,field)) exp field
- | Ast0.Cast(lp,ty,rp,exp) ->
- let exp = expression exp in
- mkres e (Ast0.Cast(lp,typeC ty,rp,exp)) (promote_mcode lp) exp
- | Ast0.SizeOfExpr(szf,exp) ->
- let exp = expression exp in
- mkres e (Ast0.SizeOfExpr(szf,exp)) (promote_mcode szf) exp
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- mkres e (Ast0.SizeOfType(szf,lp,typeC ty,rp))
- (promote_mcode szf) (promote_mcode rp)
- | Ast0.TypeExp(ty) ->
- let ty = typeC ty in mkres e (Ast0.TypeExp(ty)) ty ty
- | Ast0.MetaErr(name,_,_) | Ast0.MetaExpr(name,_,_,_,_)
- | Ast0.MetaExprList(name,_,_) as ue ->
- let ln = promote_mcode name in mkres e ue ln ln
- | Ast0.EComma(cm) ->
- let cm = bad_mcode cm in
- let ln = promote_mcode cm in
- mkres e (Ast0.EComma(cm)) ln ln
- | Ast0.DisjExpr(starter,exps,mids,ender) ->
- let starter = bad_mcode starter in
- let exps = List.map expression exps in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- mkmultires e (Ast0.DisjExpr(starter,exps,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info exps) (get_all_end_info exps)
- | Ast0.NestExpr(starter,exp_dots,ender,whencode,multi) ->
- let exp_dots = dots is_exp_dots None expression exp_dots in
- let starter = bad_mcode starter in
- let ender = bad_mcode ender in
- mkres e (Ast0.NestExpr(starter,exp_dots,ender,whencode,multi))
- (promote_mcode starter) (promote_mcode ender)
- | Ast0.Edots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres e (Ast0.Edots(dots,whencode)) ln ln
- | Ast0.Ecircles(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres e (Ast0.Ecircles(dots,whencode)) ln ln
- | Ast0.Estars(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres e (Ast0.Estars(dots,whencode)) ln ln
- | Ast0.OptExp(exp) ->
- let exp = expression exp in
- mkres e (Ast0.OptExp(exp)) exp exp
- | Ast0.UniqueExp(exp) ->
- let exp = expression exp in
- mkres e (Ast0.UniqueExp(exp)) exp exp
-
-and expression_dots x = dots is_exp_dots None expression x
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and typeC t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) ->
- let ty = typeC ty in
- mkres t (Ast0.ConstVol(cv,ty)) (promote_mcode cv) ty
- | Ast0.BaseType(ty,strings) as ut ->
- let first = List.hd strings in
- let last = List.hd (List.rev strings) in
- mkres t ut (promote_mcode first) (promote_mcode last)
- | Ast0.Signed(sgn,None) as ut ->
- mkres t ut (promote_mcode sgn) (promote_mcode sgn)
- | Ast0.Signed(sgn,Some ty) ->
- let ty = typeC ty in
- mkres t (Ast0.Signed(sgn,Some ty)) (promote_mcode sgn) ty
- | Ast0.Pointer(ty,star) ->
- let ty = typeC ty in
- mkres t (Ast0.Pointer(ty,star)) ty (promote_mcode star)
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- let ty = typeC ty in
- let params = parameter_list (Some(promote_mcode lp2)) params in
- mkres t (Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2))
- ty (promote_mcode rp2)
- | Ast0.FunctionType(Some ty,lp1,params,rp1) ->
- let ty = typeC ty in
- let params = parameter_list (Some(promote_mcode lp1)) params in
- let res = Ast0.FunctionType(Some ty,lp1,params,rp1) in
- mkres t res ty (promote_mcode rp1)
- | Ast0.FunctionType(None,lp1,params,rp1) ->
- let params = parameter_list (Some(promote_mcode lp1)) params in
- let res = Ast0.FunctionType(None,lp1,params,rp1) in
- mkres t res (promote_mcode lp1) (promote_mcode rp1)
- | Ast0.Array(ty,lb,size,rb) ->
- let ty = typeC ty in
- mkres t (Ast0.Array(ty,lb,get_option expression size,rb))
- ty (promote_mcode rb)
- | Ast0.EnumName(kind,name) ->
- let name = ident name in
- mkres t (Ast0.EnumName(kind,name)) (promote_mcode kind) name
- | Ast0.StructUnionName(kind,Some name) ->
- let name = ident name in
- mkres t (Ast0.StructUnionName(kind,Some name)) (promote_mcode kind) name
- | Ast0.StructUnionName(kind,None) ->
- let mc = promote_mcode kind in
- mkres t (Ast0.StructUnionName(kind,None)) mc mc
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- let ty = typeC ty in
- let decls =
- dots is_decl_dots (Some(promote_mcode lb)) declaration decls in
- mkres t (Ast0.StructUnionDef(ty,lb,decls,rb)) ty (promote_mcode rb)
- | Ast0.TypeName(name) as ut ->
- let ln = promote_mcode name in mkres t ut ln ln
- | Ast0.MetaType(name,_) as ut ->
- let ln = promote_mcode name in mkres t ut ln ln
- | Ast0.DisjType(starter,types,mids,ender) ->
- let starter = bad_mcode starter in
- let types = List.map typeC types in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- mkmultires t (Ast0.DisjType(starter,types,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info types) (get_all_end_info types)
- | Ast0.OptType(ty) ->
- let ty = typeC ty in mkres t (Ast0.OptType(ty)) ty ty
- | Ast0.UniqueType(ty) ->
- let ty = typeC ty in mkres t (Ast0.UniqueType(ty)) ty ty
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and is_decl_dots s =
- match Ast0.unwrap s with
- Ast0.Ddots(_,_) -> true
- | _ -> false
-
-and declaration d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,exp,sem) ->
- let ty = typeC ty in
- let id = ident id in
- let exp = initialiser exp in
- (match stg with
- None ->
- mkres d (Ast0.Init(stg,ty,id,eq,exp,sem)) ty (promote_mcode sem)
- | Some x ->
- mkres d (Ast0.Init(stg,ty,id,eq,exp,sem))
- (promote_mcode x) (promote_mcode sem))
- | Ast0.UnInit(stg,ty,id,sem) ->
- let ty = typeC ty in
- let id = ident id in
- (match stg with
- None ->
- mkres d (Ast0.UnInit(stg,ty,id,sem)) ty (promote_mcode sem)
- | Some x ->
- mkres d (Ast0.UnInit(stg,ty,id,sem))
- (promote_mcode x) (promote_mcode sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- let name = ident name in
- let args = dots is_exp_dots (Some(promote_mcode lp)) expression args in
- mkres d (Ast0.MacroDecl(name,lp,args,rp,sem)) name (promote_mcode sem)
- | Ast0.TyDecl(ty,sem) ->
- let ty = typeC ty in
- mkres d (Ast0.TyDecl(ty,sem)) ty (promote_mcode sem)
- | Ast0.Typedef(stg,ty,id,sem) ->
- let ty = typeC ty in
- let id = typeC id in
- mkres d (Ast0.Typedef(stg,ty,id,sem))
- (promote_mcode stg) (promote_mcode sem)
- | Ast0.DisjDecl(starter,decls,mids,ender) ->
- let starter = bad_mcode starter in
- let decls = List.map declaration decls in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- mkmultires d (Ast0.DisjDecl(starter,decls,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info decls) (get_all_end_info decls)
- | Ast0.Ddots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres d (Ast0.Ddots(dots,whencode)) ln ln
- | Ast0.OptDecl(decl) ->
- let decl = declaration decl in
- mkres d (Ast0.OptDecl(declaration decl)) decl decl
- | Ast0.UniqueDecl(decl) ->
- let decl = declaration decl in
- mkres d (Ast0.UniqueDecl(declaration decl)) decl decl
-
-(* --------------------------------------------------------------------- *)
-(* Initializer *)
-
-and is_init_dots i =
- match Ast0.unwrap i with
- Ast0.Idots(_,_) -> true
- | _ -> false
-
-and initialiser i =
- match Ast0.unwrap i with
- Ast0.InitExpr(exp) ->
- let exp = expression exp in
- mkres i (Ast0.InitExpr(exp)) exp exp
- | Ast0.InitList(lb,initlist,rb) ->
- let initlist =
- dots is_init_dots (Some(promote_mcode lb)) initialiser initlist in
- mkres i (Ast0.InitList(lb,initlist,rb))
- (promote_mcode lb) (promote_mcode rb)
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- let name = ident name in
- let ini = initialiser ini in
- mkres i (Ast0.InitGccDotName(dot,name,eq,ini)) (promote_mcode dot) ini
- | Ast0.InitGccName(name,eq,ini) ->
- let name = ident name in
- let ini = initialiser ini in
- mkres i (Ast0.InitGccName(name,eq,ini)) name ini
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- let exp = expression exp in
- let ini = initialiser ini in
- mkres i (Ast0.InitGccIndex(lb,exp,rb,eq,ini)) (promote_mcode lb) ini
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- let exp1 = expression exp1 in
- let exp2 = expression exp2 in
- let ini = initialiser ini in
- mkres i (Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini))
- (promote_mcode lb) ini
- | Ast0.IComma(cm) as up ->
- let ln = promote_mcode cm in mkres i up ln ln
- | Ast0.Idots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres i (Ast0.Idots(dots,whencode)) ln ln
- | Ast0.OptIni(ini) ->
- let ini = initialiser ini in
- mkres i (Ast0.OptIni(ini)) ini ini
- | Ast0.UniqueIni(ini) ->
- let ini = initialiser ini in
- mkres i (Ast0.UniqueIni(ini)) ini ini
-
-and initialiser_list prev = dots is_init_dots prev initialiser
-
-(* for export *)
-and initialiser_dots x = dots is_init_dots None initialiser x
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and is_param_dots p =
- match Ast0.unwrap p with
- Ast0.Pdots(_) | Ast0.Pcircles(_) -> true
- | _ -> false
-
-and parameterTypeDef p =
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) ->
- let ty = typeC ty in mkres p (Ast0.VoidParam(ty)) ty ty
- | Ast0.Param(ty,Some id) ->
- let id = ident id in
- let ty = typeC ty in mkres p (Ast0.Param(ty,Some id)) ty id
- | Ast0.Param(ty,None) ->
- let ty = typeC ty in mkres p (Ast0.Param(ty,None)) ty ty
- | Ast0.MetaParam(name,_) as up ->
- let ln = promote_mcode name in mkres p up ln ln
- | Ast0.MetaParamList(name,_,_) as up ->
- let ln = promote_mcode name in mkres p up ln ln
- | Ast0.PComma(cm) ->
- let cm = bad_mcode cm in
- let ln = promote_mcode cm in
- mkres p (Ast0.PComma(cm)) ln ln
- | Ast0.Pdots(dots) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres p (Ast0.Pdots(dots)) ln ln
- | Ast0.Pcircles(dots) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres p (Ast0.Pcircles(dots)) ln ln
- | Ast0.OptParam(param) ->
- let res = parameterTypeDef param in
- mkres p (Ast0.OptParam(res)) res res
- | Ast0.UniqueParam(param) ->
- let res = parameterTypeDef param in
- mkres p (Ast0.UniqueParam(res)) res res
-
-and parameter_list prev = dots is_param_dots prev parameterTypeDef
-
-(* for export *)
-let parameter_dots x = dots is_param_dots None parameterTypeDef x
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-let is_stm_dots s =
- match Ast0.unwrap s with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> true
- | _ -> false
-
-let rec statement s =
- let res =
- match Ast0.unwrap s with
- Ast0.Decl((_,bef),decl) ->
- let decl = declaration decl in
- let left = promote_to_statement_start decl bef in
- mkres s (Ast0.Decl((Ast0.get_info left,bef),decl)) decl decl
- | Ast0.Seq(lbrace,body,rbrace) ->
- let body =
- dots is_stm_dots (Some(promote_mcode lbrace)) statement body in
- mkres s (Ast0.Seq(lbrace,body,rbrace))
- (promote_mcode lbrace) (promote_mcode rbrace)
- | Ast0.ExprStatement(exp,sem) ->
- let exp = expression exp in
- mkres s (Ast0.ExprStatement(exp,sem)) exp (promote_mcode sem)
- | Ast0.IfThen(iff,lp,exp,rp,branch,(_,aft)) ->
- let exp = expression exp in
- let branch = statement branch in
- let right = promote_to_statement branch aft in
- mkres s (Ast0.IfThen(iff,lp,exp,rp,branch,(Ast0.get_info right,aft)))
- (promote_mcode iff) right
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,(_,aft)) ->
- let exp = expression exp in
- let branch1 = statement branch1 in
- let branch2 = statement branch2 in
- let right = promote_to_statement branch2 aft in
- mkres s
- (Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,
- (Ast0.get_info right,aft)))
- (promote_mcode iff) right
- | Ast0.While(wh,lp,exp,rp,body,(_,aft)) ->
- let exp = expression exp in
- let body = statement body in
- let right = promote_to_statement body aft in
- mkres s (Ast0.While(wh,lp,exp,rp,body,(Ast0.get_info right,aft)))
- (promote_mcode wh) right
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- let body = statement body in
- let exp = expression exp in
- mkres s (Ast0.Do(d,body,wh,lp,exp,rp,sem))
- (promote_mcode d) (promote_mcode sem)
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,(_,aft)) ->
- let exp1 = get_option expression exp1 in
- let exp2 = get_option expression exp2 in
- let exp3 = get_option expression exp3 in
- let body = statement body in
- let right = promote_to_statement body aft in
- mkres s (Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,
- (Ast0.get_info right,aft)))
- (promote_mcode fr) right
- | Ast0.Iterator(nm,lp,args,rp,body,(_,aft)) ->
- let nm = ident nm in
- let args = dots is_exp_dots (Some(promote_mcode lp)) expression args in
- let body = statement body in
- let right = promote_to_statement body aft in
- mkres s (Ast0.Iterator(nm,lp,args,rp,body,(Ast0.get_info right,aft)))
- nm right
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- let exp = expression exp in
- let cases =
- dots (function _ -> false) (Some(promote_mcode lb)) case_line cases in
- mkres s
- (Ast0.Switch(switch,lp,exp,rp,lb,cases,rb))
- (promote_mcode switch) (promote_mcode rb)
- | Ast0.Break(br,sem) as us ->
- mkres s us (promote_mcode br) (promote_mcode sem)
- | Ast0.Continue(cont,sem) as us ->
- mkres s us (promote_mcode cont) (promote_mcode sem)
- | Ast0.Label(l,dd) ->
- let l = ident l in
- mkres s (Ast0.Label(l,dd)) l (promote_mcode dd)
- | Ast0.Goto(goto,id,sem) ->
- let id = ident id in
- mkres s (Ast0.Goto(goto,id,sem))
- (promote_mcode goto) (promote_mcode sem)
- | Ast0.Return(ret,sem) as us ->
- mkres s us (promote_mcode ret) (promote_mcode sem)
- | Ast0.ReturnExpr(ret,exp,sem) ->
- let exp = expression exp in
- mkres s (Ast0.ReturnExpr(ret,exp,sem))
- (promote_mcode ret) (promote_mcode sem)
- | Ast0.MetaStmt(name,_)
- | Ast0.MetaStmtList(name,_) as us ->
- let ln = promote_mcode name in mkres s us ln ln
- | Ast0.Exp(exp) ->
- let exp = expression exp in
- mkres s (Ast0.Exp(exp)) exp exp
- | Ast0.TopExp(exp) ->
- let exp = expression exp in
- mkres s (Ast0.TopExp(exp)) exp exp
- | Ast0.Ty(ty) ->
- let ty = typeC ty in
- mkres s (Ast0.Ty(ty)) ty ty
- | Ast0.TopInit(init) ->
- let init = initialiser init in
- mkres s (Ast0.TopInit(init)) init init
- | Ast0.Disj(starter,rule_elem_dots_list,mids,ender) ->
- let starter = bad_mcode starter in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- let rec loop prevs = function
- [] -> []
- | stm::stms ->
- (dots is_stm_dots (Some(promote_mcode_plus_one(List.hd prevs)))
- statement stm)::
- (loop (List.tl prevs) stms) in
- let elems = loop (starter::mids) rule_elem_dots_list in
- mkmultires s (Ast0.Disj(starter,elems,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info elems) (get_all_end_info elems)
- | Ast0.Nest(starter,rule_elem_dots,ender,whencode,multi) ->
- let starter = bad_mcode starter in
- let ender = bad_mcode ender in
- let rule_elem_dots = dots is_stm_dots None statement rule_elem_dots in
- mkres s (Ast0.Nest(starter,rule_elem_dots,ender,whencode,multi))
- (promote_mcode starter) (promote_mcode ender)
- | Ast0.Dots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres s (Ast0.Dots(dots,whencode)) ln ln
- | Ast0.Circles(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres s (Ast0.Circles(dots,whencode)) ln ln
- | Ast0.Stars(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres s (Ast0.Stars(dots,whencode)) ln ln
- | Ast0.FunDecl((_,bef),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- let fninfo =
- List.map
- (function Ast0.FType(ty) -> Ast0.FType(typeC ty) | x -> x)
- fninfo in
- let name = ident name in
- let params = parameter_list (Some(promote_mcode lp)) params in
- let body =
- dots is_stm_dots (Some(promote_mcode lbrace)) statement body in
- let left =
- (* cases on what is leftmost *)
- match fninfo with
- [] -> promote_to_statement_start name bef
- | Ast0.FStorage(stg)::_ ->
- promote_to_statement_start (promote_mcode stg) bef
- | Ast0.FType(ty)::_ ->
- promote_to_statement_start ty bef
- | Ast0.FInline(inline)::_ ->
- promote_to_statement_start (promote_mcode inline) bef
- | Ast0.FAttr(attr)::_ ->
- promote_to_statement_start (promote_mcode attr) bef in
- (* pretend it is one line before the start of the function, so that it
- will catch things defined at top level. We assume that these will not
- be defined on the same line as the function. This is a HACK.
- A better approach would be to attach top_level things to this node,
- and other things to the node after, but that would complicate
- insert_plus, which doesn't distinguish between different mcodekinds *)
- let res =
- Ast0.FunDecl((Ast0.get_info left,bef),fninfo,name,lp,params,rp,lbrace,
- body,rbrace) in
- (* have to do this test again, because of typing problems - can't save
- the result, only use it *)
- (match fninfo with
- [] -> mkres s res name (promote_mcode rbrace)
- | Ast0.FStorage(stg)::_ ->
- mkres s res (promote_mcode stg) (promote_mcode rbrace)
- | Ast0.FType(ty)::_ -> mkres s res ty (promote_mcode rbrace)
- | Ast0.FInline(inline)::_ ->
- mkres s res (promote_mcode inline) (promote_mcode rbrace)
- | Ast0.FAttr(attr)::_ ->
- mkres s res (promote_mcode attr) (promote_mcode rbrace))
-
- | Ast0.Include(inc,stm) ->
- mkres s (Ast0.Include(inc,stm)) (promote_mcode inc) (promote_mcode stm)
- | Ast0.Define(def,id,params,body) ->
- let id = ident id in
- let body = dots is_stm_dots None statement body in
- mkres s (Ast0.Define(def,id,params,body)) (promote_mcode def) body
- | Ast0.OptStm(stm) ->
- let stm = statement stm in mkres s (Ast0.OptStm(stm)) stm stm
- | Ast0.UniqueStm(stm) ->
- let stm = statement stm in mkres s (Ast0.UniqueStm(stm)) stm stm in
- Ast0.set_dots_bef_aft res
- (match Ast0.get_dots_bef_aft res with
- Ast0.NoDots -> Ast0.NoDots
- | Ast0.AddingBetweenDots s ->
- Ast0.AddingBetweenDots(statement s)
- | Ast0.DroppingBetweenDots s ->
- Ast0.DroppingBetweenDots(statement s))
-
-and case_line c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- let code = dots is_stm_dots (Some(promote_mcode colon)) statement code in
- mkres c (Ast0.Default(def,colon,code)) (promote_mcode def) code
- | Ast0.Case(case,exp,colon,code) ->
- let exp = expression exp in
- let code = dots is_stm_dots (Some(promote_mcode colon)) statement code in
- mkres c (Ast0.Case(case,exp,colon,code)) (promote_mcode case) code
- | Ast0.OptCase(case) ->
- let case = case_line case in mkres c (Ast0.OptCase(case)) case case
-
-and statement_dots x = dots is_stm_dots None statement x
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-
-let top_level t =
- match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) -> t
- | Ast0.DECL(stmt) ->
- let stmt = statement stmt in mkres t (Ast0.DECL(stmt)) stmt stmt
- | Ast0.CODE(rule_elem_dots) ->
- let rule_elem_dots = dots is_stm_dots None statement rule_elem_dots in
- mkres t (Ast0.CODE(rule_elem_dots)) rule_elem_dots rule_elem_dots
- | Ast0.ERRORWORDS(exps) -> t
- | Ast0.OTHER(_) -> failwith "eliminated by top_level"
-
-(* --------------------------------------------------------------------- *)
-(* Entry points *)
-
-let compute_lines = List.map top_level
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Computes starting and ending logical lines for statements and
-expressions. every node gets an index as well. *)
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Result *)
-
-let mkres x e left right =
- let lstart = Ast0.get_info left in
- let lend = Ast0.get_info right in
- let info =
- { Ast0.line_start = lstart.Ast0.line_start;
- Ast0.line_end = lend.Ast0.line_end;
- Ast0.logical_start = lstart.Ast0.logical_start;
- Ast0.logical_end = lend.Ast0.logical_end;
- Ast0.attachable_start = lstart.Ast0.attachable_start;
- Ast0.attachable_end = lend.Ast0.attachable_end;
- Ast0.mcode_start = lstart.Ast0.mcode_start;
- Ast0.mcode_end = lend.Ast0.mcode_end;
- Ast0.column = lstart.Ast0.column;
- Ast0.offset = lstart.Ast0.offset;
- (* only for tokens, not inherited upwards *)
- Ast0.strings_before = []; Ast0.strings_after = []} in
- {x with Ast0.node = e; Ast0.info = info}
-
-let mkmultires x e left right (astart,start_mcodes) (aend,end_mcodes) =
- let lstart = Ast0.get_info left in
- let lend = Ast0.get_info right in
- let info =
- { Ast0.line_start = lstart.Ast0.line_start;
- Ast0.line_end = lend.Ast0.line_end;
- Ast0.logical_start = lstart.Ast0.logical_start;
- Ast0.logical_end = lend.Ast0.logical_end;
- Ast0.attachable_start = astart;
- Ast0.attachable_end = aend;
- Ast0.mcode_start = start_mcodes;
- Ast0.mcode_end = end_mcodes;
- Ast0.column = lstart.Ast0.column;
- Ast0.offset = lstart.Ast0.offset;
- (* only for tokens, not inherited upwards *)
- Ast0.strings_before = []; Ast0.strings_after = [] } in
- {x with Ast0.node = e; Ast0.info = info}
-
-(* --------------------------------------------------------------------- *)
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Mcode *)
-
-let promote_mcode (_,_,info,mcodekind,_) =
- let new_info =
- {info with
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind]} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-let promote_mcode_plus_one (_,_,info,mcodekind,_) =
- let new_info =
- {info with
- Ast0.line_start = info.Ast0.line_start + 1;
- Ast0.logical_start = info.Ast0.logical_start + 1;
- Ast0.line_end = info.Ast0.line_end + 1;
- Ast0.logical_end = info.Ast0.logical_end + 1;
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind]} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-let promote_to_statement stm mcodekind =
- let info = Ast0.get_info stm in
- let new_info =
- {info with
- Ast0.logical_start = info.Ast0.logical_end;
- Ast0.line_start = info.Ast0.line_end;
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind];
- Ast0.attachable_start = true; Ast0.attachable_end = true} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-let promote_to_statement_start stm mcodekind =
- let info = Ast0.get_info stm in
- let new_info =
- {info with
- Ast0.logical_end = info.Ast0.logical_start;
- Ast0.line_end = info.Ast0.line_start;
- Ast0.mcode_start = [mcodekind]; Ast0.mcode_end = [mcodekind];
- Ast0.attachable_start = true; Ast0.attachable_end = true} in
- {(Ast0.wrap ()) with Ast0.info = new_info; Ast0.mcodekind = ref mcodekind}
-
-(* mcode is good by default *)
-let bad_mcode (t,a,info,mcodekind,pos) =
- let new_info =
- {info with Ast0.attachable_start = false; Ast0.attachable_end = false} in
- (t,a,new_info,mcodekind,pos)
-
-let get_all_start_info l =
- (List.for_all (function x -> (Ast0.get_info x).Ast0.attachable_start) l,
- List.concat (List.map (function x -> (Ast0.get_info x).Ast0.mcode_start) l))
-
-let get_all_end_info l =
- (List.for_all (function x -> (Ast0.get_info x).Ast0.attachable_end) l,
- List.concat (List.map (function x -> (Ast0.get_info x).Ast0.mcode_end) l))
-
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-(* for the logline classification and the mcode field, on both sides, skip
-over initial minus dots, as they don't contribute anything *)
-let dot_list is_dots fn = function
- [] -> failwith "dots should not be empty"
- | l ->
- let get_node l fn =
- let first = List.hd l in
- let chosen =
- match (is_dots first, l) with (true,_::x::_) -> x | _ -> first in
- (* get the logline decorator and the mcodekind of the chosen node *)
- fn (Ast0.get_info chosen) in
- let forward = List.map fn l in
- let backward = List.rev forward in
- let (first_attachable,first_mcode) =
- get_node forward
- (function x -> (x.Ast0.attachable_start,x.Ast0.mcode_start)) in
- let (last_attachable,last_mcode) =
- get_node backward
- (function x -> (x.Ast0.attachable_end,x.Ast0.mcode_end)) in
- let first = List.hd forward in
- let last = List.hd backward in
- let first_info =
- { (Ast0.get_info first) with
- Ast0.attachable_start = first_attachable;
- Ast0.mcode_start = first_mcode } in
- let last_info =
- { (Ast0.get_info last) with
- Ast0.attachable_end = last_attachable;
- Ast0.mcode_end = last_mcode } in
- let first = Ast0.set_info first first_info in
- let last = Ast0.set_info last last_info in
- (forward,first,last)
-
-let dots is_dots prev fn d =
- match (prev,Ast0.unwrap d) with
- (Some prev,Ast0.DOTS([])) ->
- mkres d (Ast0.DOTS []) prev prev
- | (None,Ast0.DOTS([])) ->
- Ast0.set_info d
- {(Ast0.get_info d)
- with Ast0.attachable_start = false; Ast0.attachable_end = false}
- | (_,Ast0.DOTS(x)) ->
- let (l,lstart,lend) = dot_list is_dots fn x in
- mkres d (Ast0.DOTS l) lstart lend
- | (_,Ast0.CIRCLES(x)) ->
- let (l,lstart,lend) = dot_list is_dots fn x in
- mkres d (Ast0.CIRCLES l) lstart lend
- | (_,Ast0.STARS(x)) ->
- let (l,lstart,lend) = dot_list is_dots fn x in
- mkres d (Ast0.STARS l) lstart lend
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec ident i =
- match Ast0.unwrap i with
- Ast0.Id(name) as ui ->
- let name = promote_mcode name in mkres i ui name name
- | Ast0.MetaId(name,_,_)
- | Ast0.MetaFunc(name,_,_) | Ast0.MetaLocalFunc(name,_,_) as ui ->
- let name = promote_mcode name in mkres i ui name name
- | Ast0.OptIdent(id) ->
- let id = ident id in mkres i (Ast0.OptIdent(id)) id id
- | Ast0.UniqueIdent(id) ->
- let id = ident id in mkres i (Ast0.UniqueIdent(id)) id id
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let is_exp_dots e =
- match Ast0.unwrap e with
- Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> true
- | _ -> false
-
-let rec expression e =
- match Ast0.unwrap e with
- Ast0.Ident(id) ->
- let id = ident id in
- mkres e (Ast0.Ident(id)) id id
- | Ast0.Constant(const) as ue ->
- let ln = promote_mcode const in
- mkres e ue ln ln
- | Ast0.FunCall(fn,lp,args,rp) ->
- let fn = expression fn in
- let args = dots is_exp_dots (Some(promote_mcode lp)) expression args in
- mkres e (Ast0.FunCall(fn,lp,args,rp)) fn (promote_mcode rp)
- | Ast0.Assignment(left,op,right,simple) ->
- let left = expression left in
- let right = expression right in
- mkres e (Ast0.Assignment(left,op,right,simple)) left right
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- let exp1 = expression exp1 in
- let exp2 = get_option expression exp2 in
- let exp3 = expression exp3 in
- mkres e (Ast0.CondExpr(exp1,why,exp2,colon,exp3)) exp1 exp3
- | Ast0.Postfix(exp,op) ->
- let exp = expression exp in
- mkres e (Ast0.Postfix(exp,op)) exp (promote_mcode op)
- | Ast0.Infix(exp,op) ->
- let exp = expression exp in
- mkres e (Ast0.Infix(exp,op)) (promote_mcode op) exp
- | Ast0.Unary(exp,op) ->
- let exp = expression exp in
- mkres e (Ast0.Unary(exp,op)) (promote_mcode op) exp
- | Ast0.Binary(left,op,right) ->
- let left = expression left in
- let right = expression right in
- mkres e (Ast0.Binary(left,op,right)) left right
- | Ast0.Nested(left,op,right) ->
- let left = expression left in
- let right = expression right in
- mkres e (Ast0.Nested(left,op,right)) left right
- | Ast0.Paren(lp,exp,rp) ->
- mkres e (Ast0.Paren(lp,expression exp,rp))
- (promote_mcode lp) (promote_mcode rp)
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- let exp1 = expression exp1 in
- let exp2 = expression exp2 in
- mkres e (Ast0.ArrayAccess(exp1,lb,exp2,rb)) exp1 (promote_mcode rb)
- | Ast0.RecordAccess(exp,pt,field) ->
- let exp = expression exp in
- let field = ident field in
- mkres e (Ast0.RecordAccess(exp,pt,field)) exp field
- | Ast0.RecordPtAccess(exp,ar,field) ->
- let exp = expression exp in
- let field = ident field in
- mkres e (Ast0.RecordPtAccess(exp,ar,field)) exp field
- | Ast0.Cast(lp,ty,rp,exp) ->
- let exp = expression exp in
- mkres e (Ast0.Cast(lp,typeC ty,rp,exp)) (promote_mcode lp) exp
- | Ast0.SizeOfExpr(szf,exp) ->
- let exp = expression exp in
- mkres e (Ast0.SizeOfExpr(szf,exp)) (promote_mcode szf) exp
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- mkres e (Ast0.SizeOfType(szf,lp,typeC ty,rp))
- (promote_mcode szf) (promote_mcode rp)
- | Ast0.TypeExp(ty) ->
- let ty = typeC ty in mkres e (Ast0.TypeExp(ty)) ty ty
- | Ast0.MetaErr(name,_,_) | Ast0.MetaExpr(name,_,_,_,_)
- | Ast0.MetaExprList(name,_,_) as ue ->
- let ln = promote_mcode name in mkres e ue ln ln
- | Ast0.EComma(cm) ->
- let cm = bad_mcode cm in
- let ln = promote_mcode cm in
- mkres e (Ast0.EComma(cm)) ln ln
- | Ast0.DisjExpr(starter,exps,mids,ender) ->
- let starter = bad_mcode starter in
- let exps = List.map expression exps in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- mkmultires e (Ast0.DisjExpr(starter,exps,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info exps) (get_all_end_info exps)
- | Ast0.NestExpr(starter,exp_dots,ender,whencode,multi) ->
- let exp_dots = dots is_exp_dots None expression exp_dots in
- let starter = bad_mcode starter in
- let ender = bad_mcode ender in
- mkres e (Ast0.NestExpr(starter,exp_dots,ender,whencode,multi))
- (promote_mcode starter) (promote_mcode ender)
- | Ast0.Edots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres e (Ast0.Edots(dots,whencode)) ln ln
- | Ast0.Ecircles(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres e (Ast0.Ecircles(dots,whencode)) ln ln
- | Ast0.Estars(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres e (Ast0.Estars(dots,whencode)) ln ln
- | Ast0.OptExp(exp) ->
- let exp = expression exp in
- mkres e (Ast0.OptExp(exp)) exp exp
- | Ast0.UniqueExp(exp) ->
- let exp = expression exp in
- mkres e (Ast0.UniqueExp(exp)) exp exp
-
-and expression_dots x = dots is_exp_dots None expression x
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and typeC t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) ->
- let ty = typeC ty in
- mkres t (Ast0.ConstVol(cv,ty)) (promote_mcode cv) ty
- | Ast0.BaseType(ty,strings) as ut ->
- let first = List.hd strings in
- let last = List.hd (List.rev strings) in
- mkres t ut (promote_mcode first) (promote_mcode last)
- | Ast0.Signed(sgn,None) as ut ->
- mkres t ut (promote_mcode sgn) (promote_mcode sgn)
- | Ast0.Signed(sgn,Some ty) ->
- let ty = typeC ty in
- mkres t (Ast0.Signed(sgn,Some ty)) (promote_mcode sgn) ty
- | Ast0.Pointer(ty,star) ->
- let ty = typeC ty in
- mkres t (Ast0.Pointer(ty,star)) ty (promote_mcode star)
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- let ty = typeC ty in
- let params = parameter_list (Some(promote_mcode lp2)) params in
- mkres t (Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2))
- ty (promote_mcode rp2)
- | Ast0.FunctionType(Some ty,lp1,params,rp1) ->
- let ty = typeC ty in
- let params = parameter_list (Some(promote_mcode lp1)) params in
- let res = Ast0.FunctionType(Some ty,lp1,params,rp1) in
- mkres t res ty (promote_mcode rp1)
- | Ast0.FunctionType(None,lp1,params,rp1) ->
- let params = parameter_list (Some(promote_mcode lp1)) params in
- let res = Ast0.FunctionType(None,lp1,params,rp1) in
- mkres t res (promote_mcode lp1) (promote_mcode rp1)
- | Ast0.Array(ty,lb,size,rb) ->
- let ty = typeC ty in
- mkres t (Ast0.Array(ty,lb,get_option expression size,rb))
- ty (promote_mcode rb)
- | Ast0.EnumName(kind,name) ->
- let name = ident name in
- mkres t (Ast0.EnumName(kind,name)) (promote_mcode kind) name
- | Ast0.StructUnionName(kind,Some name) ->
- let name = ident name in
- mkres t (Ast0.StructUnionName(kind,Some name)) (promote_mcode kind) name
- | Ast0.StructUnionName(kind,None) ->
- let mc = promote_mcode kind in
- mkres t (Ast0.StructUnionName(kind,None)) mc mc
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- let ty = typeC ty in
- let decls =
- dots is_decl_dots (Some(promote_mcode lb)) declaration decls in
- mkres t (Ast0.StructUnionDef(ty,lb,decls,rb)) ty (promote_mcode rb)
- | Ast0.TypeName(name) as ut ->
- let ln = promote_mcode name in mkres t ut ln ln
- | Ast0.MetaType(name,_) as ut ->
- let ln = promote_mcode name in mkres t ut ln ln
- | Ast0.DisjType(starter,types,mids,ender) ->
- let starter = bad_mcode starter in
- let types = List.map typeC types in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- mkmultires t (Ast0.DisjType(starter,types,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info types) (get_all_end_info types)
- | Ast0.OptType(ty) ->
- let ty = typeC ty in mkres t (Ast0.OptType(ty)) ty ty
- | Ast0.UniqueType(ty) ->
- let ty = typeC ty in mkres t (Ast0.UniqueType(ty)) ty ty
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and is_decl_dots s =
- match Ast0.unwrap s with
- Ast0.Ddots(_,_) -> true
- | _ -> false
-
-and declaration d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,exp,sem) ->
- let ty = typeC ty in
- let id = ident id in
- let exp = initialiser exp in
- (match stg with
- None ->
- mkres d (Ast0.Init(stg,ty,id,eq,exp,sem)) ty (promote_mcode sem)
- | Some x ->
- mkres d (Ast0.Init(stg,ty,id,eq,exp,sem))
- (promote_mcode x) (promote_mcode sem))
- | Ast0.UnInit(stg,ty,id,sem) ->
- let ty = typeC ty in
- let id = ident id in
- (match stg with
- None ->
- mkres d (Ast0.UnInit(stg,ty,id,sem)) ty (promote_mcode sem)
- | Some x ->
- mkres d (Ast0.UnInit(stg,ty,id,sem))
- (promote_mcode x) (promote_mcode sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- let name = ident name in
- let args = dots is_exp_dots (Some(promote_mcode lp)) expression args in
- mkres d (Ast0.MacroDecl(name,lp,args,rp,sem)) name (promote_mcode sem)
- | Ast0.TyDecl(ty,sem) ->
- let ty = typeC ty in
- mkres d (Ast0.TyDecl(ty,sem)) ty (promote_mcode sem)
- | Ast0.Typedef(stg,ty,id,sem) ->
- let ty = typeC ty in
- let id = typeC id in
- mkres d (Ast0.Typedef(stg,ty,id,sem))
- (promote_mcode stg) (promote_mcode sem)
- | Ast0.DisjDecl(starter,decls,mids,ender) ->
- let starter = bad_mcode starter in
- let decls = List.map declaration decls in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- mkmultires d (Ast0.DisjDecl(starter,decls,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info decls) (get_all_end_info decls)
- | Ast0.Ddots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres d (Ast0.Ddots(dots,whencode)) ln ln
- | Ast0.OptDecl(decl) ->
- let decl = declaration decl in
- mkres d (Ast0.OptDecl(declaration decl)) decl decl
- | Ast0.UniqueDecl(decl) ->
- let decl = declaration decl in
- mkres d (Ast0.UniqueDecl(declaration decl)) decl decl
-
-(* --------------------------------------------------------------------- *)
-(* Initializer *)
-
-and is_init_dots i =
- match Ast0.unwrap i with
- Ast0.Idots(_,_) -> true
- | _ -> false
-
-and initialiser i =
- match Ast0.unwrap i with
- Ast0.MetaInit(name,_) as ut ->
- let ln = promote_mcode name in mkres i ut ln ln
- | Ast0.InitExpr(exp) ->
- let exp = expression exp in
- mkres i (Ast0.InitExpr(exp)) exp exp
- | Ast0.InitList(lb,initlist,rb) ->
- let initlist =
- dots is_init_dots (Some(promote_mcode lb)) initialiser initlist in
- mkres i (Ast0.InitList(lb,initlist,rb))
- (promote_mcode lb) (promote_mcode rb)
- | Ast0.InitGccExt(designators,eq,ini) ->
- let (delims,designators) = (* non empty due to parsing *)
- List.split (List.map designator designators) in
- let ini = initialiser ini in
- mkres i (Ast0.InitGccExt(designators,eq,ini))
- (promote_mcode (List.hd delims)) ini
- | Ast0.InitGccName(name,eq,ini) ->
- let name = ident name in
- let ini = initialiser ini in
- mkres i (Ast0.InitGccName(name,eq,ini)) name ini
- | Ast0.IComma(cm) as up ->
- let ln = promote_mcode cm in mkres i up ln ln
- | Ast0.Idots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres i (Ast0.Idots(dots,whencode)) ln ln
- | Ast0.OptIni(ini) ->
- let ini = initialiser ini in
- mkres i (Ast0.OptIni(ini)) ini ini
- | Ast0.UniqueIni(ini) ->
- let ini = initialiser ini in
- mkres i (Ast0.UniqueIni(ini)) ini ini
-
-and designator = function
- Ast0.DesignatorField(dot,id) ->
- (dot,Ast0.DesignatorField(dot,ident id))
- | Ast0.DesignatorIndex(lb,exp,rb) ->
- (lb,Ast0.DesignatorIndex(lb,expression exp,rb))
- | Ast0.DesignatorRange(lb,min,dots,max,rb) ->
- (lb,Ast0.DesignatorRange(lb,expression min,dots,expression max,rb))
-
-and initialiser_list prev = dots is_init_dots prev initialiser
-
-(* for export *)
-and initialiser_dots x = dots is_init_dots None initialiser x
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and is_param_dots p =
- match Ast0.unwrap p with
- Ast0.Pdots(_) | Ast0.Pcircles(_) -> true
- | _ -> false
-
-and parameterTypeDef p =
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) ->
- let ty = typeC ty in mkres p (Ast0.VoidParam(ty)) ty ty
- | Ast0.Param(ty,Some id) ->
- let id = ident id in
- let ty = typeC ty in mkres p (Ast0.Param(ty,Some id)) ty id
- | Ast0.Param(ty,None) ->
- let ty = typeC ty in mkres p (Ast0.Param(ty,None)) ty ty
- | Ast0.MetaParam(name,_) as up ->
- let ln = promote_mcode name in mkres p up ln ln
- | Ast0.MetaParamList(name,_,_) as up ->
- let ln = promote_mcode name in mkres p up ln ln
- | Ast0.PComma(cm) ->
- let cm = bad_mcode cm in
- let ln = promote_mcode cm in
- mkres p (Ast0.PComma(cm)) ln ln
- | Ast0.Pdots(dots) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres p (Ast0.Pdots(dots)) ln ln
- | Ast0.Pcircles(dots) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres p (Ast0.Pcircles(dots)) ln ln
- | Ast0.OptParam(param) ->
- let res = parameterTypeDef param in
- mkres p (Ast0.OptParam(res)) res res
- | Ast0.UniqueParam(param) ->
- let res = parameterTypeDef param in
- mkres p (Ast0.UniqueParam(res)) res res
-
-and parameter_list prev = dots is_param_dots prev parameterTypeDef
-
-(* for export *)
-let parameter_dots x = dots is_param_dots None parameterTypeDef x
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-let is_stm_dots s =
- match Ast0.unwrap s with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> true
- | _ -> false
-
-let rec statement s =
- let res =
- match Ast0.unwrap s with
- Ast0.Decl((_,bef),decl) ->
- let decl = declaration decl in
- let left = promote_to_statement_start decl bef in
- mkres s (Ast0.Decl((Ast0.get_info left,bef),decl)) decl decl
- | Ast0.Seq(lbrace,body,rbrace) ->
- let body =
- dots is_stm_dots (Some(promote_mcode lbrace)) statement body in
- mkres s (Ast0.Seq(lbrace,body,rbrace))
- (promote_mcode lbrace) (promote_mcode rbrace)
- | Ast0.ExprStatement(exp,sem) ->
- let exp = expression exp in
- mkres s (Ast0.ExprStatement(exp,sem)) exp (promote_mcode sem)
- | Ast0.IfThen(iff,lp,exp,rp,branch,(_,aft)) ->
- let exp = expression exp in
- let branch = statement branch in
- let right = promote_to_statement branch aft in
- mkres s (Ast0.IfThen(iff,lp,exp,rp,branch,(Ast0.get_info right,aft)))
- (promote_mcode iff) right
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,(_,aft)) ->
- let exp = expression exp in
- let branch1 = statement branch1 in
- let branch2 = statement branch2 in
- let right = promote_to_statement branch2 aft in
- mkres s
- (Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,
- (Ast0.get_info right,aft)))
- (promote_mcode iff) right
- | Ast0.While(wh,lp,exp,rp,body,(_,aft)) ->
- let exp = expression exp in
- let body = statement body in
- let right = promote_to_statement body aft in
- mkres s (Ast0.While(wh,lp,exp,rp,body,(Ast0.get_info right,aft)))
- (promote_mcode wh) right
- | Ast0.Do(d,body,wh,lp,exp,rp,sem) ->
- let body = statement body in
- let exp = expression exp in
- mkres s (Ast0.Do(d,body,wh,lp,exp,rp,sem))
- (promote_mcode d) (promote_mcode sem)
- | Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,(_,aft)) ->
- let exp1 = get_option expression exp1 in
- let exp2 = get_option expression exp2 in
- let exp3 = get_option expression exp3 in
- let body = statement body in
- let right = promote_to_statement body aft in
- mkres s (Ast0.For(fr,lp,exp1,sem1,exp2,sem2,exp3,rp,body,
- (Ast0.get_info right,aft)))
- (promote_mcode fr) right
- | Ast0.Iterator(nm,lp,args,rp,body,(_,aft)) ->
- let nm = ident nm in
- let args = dots is_exp_dots (Some(promote_mcode lp)) expression args in
- let body = statement body in
- let right = promote_to_statement body aft in
- mkres s (Ast0.Iterator(nm,lp,args,rp,body,(Ast0.get_info right,aft)))
- nm right
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- let exp = expression exp in
- let cases =
- dots (function _ -> false) (Some(promote_mcode lb)) case_line cases in
- mkres s
- (Ast0.Switch(switch,lp,exp,rp,lb,cases,rb))
- (promote_mcode switch) (promote_mcode rb)
- | Ast0.Break(br,sem) as us ->
- mkres s us (promote_mcode br) (promote_mcode sem)
- | Ast0.Continue(cont,sem) as us ->
- mkres s us (promote_mcode cont) (promote_mcode sem)
- | Ast0.Label(l,dd) ->
- let l = ident l in
- mkres s (Ast0.Label(l,dd)) l (promote_mcode dd)
- | Ast0.Goto(goto,id,sem) ->
- let id = ident id in
- mkres s (Ast0.Goto(goto,id,sem))
- (promote_mcode goto) (promote_mcode sem)
- | Ast0.Return(ret,sem) as us ->
- mkres s us (promote_mcode ret) (promote_mcode sem)
- | Ast0.ReturnExpr(ret,exp,sem) ->
- let exp = expression exp in
- mkres s (Ast0.ReturnExpr(ret,exp,sem))
- (promote_mcode ret) (promote_mcode sem)
- | Ast0.MetaStmt(name,_)
- | Ast0.MetaStmtList(name,_) as us ->
- let ln = promote_mcode name in mkres s us ln ln
- | Ast0.Exp(exp) ->
- let exp = expression exp in
- mkres s (Ast0.Exp(exp)) exp exp
- | Ast0.TopExp(exp) ->
- let exp = expression exp in
- mkres s (Ast0.TopExp(exp)) exp exp
- | Ast0.Ty(ty) ->
- let ty = typeC ty in
- mkres s (Ast0.Ty(ty)) ty ty
- | Ast0.TopInit(init) ->
- let init = initialiser init in
- mkres s (Ast0.TopInit(init)) init init
- | Ast0.Disj(starter,rule_elem_dots_list,mids,ender) ->
- let starter = bad_mcode starter in
- let mids = List.map bad_mcode mids in
- let ender = bad_mcode ender in
- let rec loop prevs = function
- [] -> []
- | stm::stms ->
- (dots is_stm_dots (Some(promote_mcode_plus_one(List.hd prevs)))
- statement stm)::
- (loop (List.tl prevs) stms) in
- let elems = loop (starter::mids) rule_elem_dots_list in
- mkmultires s (Ast0.Disj(starter,elems,mids,ender))
- (promote_mcode starter) (promote_mcode ender)
- (get_all_start_info elems) (get_all_end_info elems)
- | Ast0.Nest(starter,rule_elem_dots,ender,whencode,multi) ->
- let starter = bad_mcode starter in
- let ender = bad_mcode ender in
- let rule_elem_dots = dots is_stm_dots None statement rule_elem_dots in
- mkres s (Ast0.Nest(starter,rule_elem_dots,ender,whencode,multi))
- (promote_mcode starter) (promote_mcode ender)
- | Ast0.Dots(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres s (Ast0.Dots(dots,whencode)) ln ln
- | Ast0.Circles(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres s (Ast0.Circles(dots,whencode)) ln ln
- | Ast0.Stars(dots,whencode) ->
- let dots = bad_mcode dots in
- let ln = promote_mcode dots in
- mkres s (Ast0.Stars(dots,whencode)) ln ln
- | Ast0.FunDecl((_,bef),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- let fninfo =
- List.map
- (function Ast0.FType(ty) -> Ast0.FType(typeC ty) | x -> x)
- fninfo in
- let name = ident name in
- let params = parameter_list (Some(promote_mcode lp)) params in
- let body =
- dots is_stm_dots (Some(promote_mcode lbrace)) statement body in
- let left =
- (* cases on what is leftmost *)
- match fninfo with
- [] -> promote_to_statement_start name bef
- | Ast0.FStorage(stg)::_ ->
- promote_to_statement_start (promote_mcode stg) bef
- | Ast0.FType(ty)::_ ->
- promote_to_statement_start ty bef
- | Ast0.FInline(inline)::_ ->
- promote_to_statement_start (promote_mcode inline) bef
- | Ast0.FAttr(attr)::_ ->
- promote_to_statement_start (promote_mcode attr) bef in
- (* pretend it is one line before the start of the function, so that it
- will catch things defined at top level. We assume that these will not
- be defined on the same line as the function. This is a HACK.
- A better approach would be to attach top_level things to this node,
- and other things to the node after, but that would complicate
- insert_plus, which doesn't distinguish between different mcodekinds *)
- let res =
- Ast0.FunDecl((Ast0.get_info left,bef),fninfo,name,lp,params,rp,lbrace,
- body,rbrace) in
- (* have to do this test again, because of typing problems - can't save
- the result, only use it *)
- (match fninfo with
- [] -> mkres s res name (promote_mcode rbrace)
- | Ast0.FStorage(stg)::_ ->
- mkres s res (promote_mcode stg) (promote_mcode rbrace)
- | Ast0.FType(ty)::_ -> mkres s res ty (promote_mcode rbrace)
- | Ast0.FInline(inline)::_ ->
- mkres s res (promote_mcode inline) (promote_mcode rbrace)
- | Ast0.FAttr(attr)::_ ->
- mkres s res (promote_mcode attr) (promote_mcode rbrace))
-
- | Ast0.Include(inc,stm) ->
- mkres s (Ast0.Include(inc,stm)) (promote_mcode inc) (promote_mcode stm)
- | Ast0.Define(def,id,params,body) ->
- let id = ident id in
- let body = dots is_stm_dots None statement body in
- mkres s (Ast0.Define(def,id,params,body)) (promote_mcode def) body
- | Ast0.OptStm(stm) ->
- let stm = statement stm in mkres s (Ast0.OptStm(stm)) stm stm
- | Ast0.UniqueStm(stm) ->
- let stm = statement stm in mkres s (Ast0.UniqueStm(stm)) stm stm in
- Ast0.set_dots_bef_aft res
- (match Ast0.get_dots_bef_aft res with
- Ast0.NoDots -> Ast0.NoDots
- | Ast0.AddingBetweenDots s ->
- Ast0.AddingBetweenDots(statement s)
- | Ast0.DroppingBetweenDots s ->
- Ast0.DroppingBetweenDots(statement s))
-
-and case_line c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- let code = dots is_stm_dots (Some(promote_mcode colon)) statement code in
- mkres c (Ast0.Default(def,colon,code)) (promote_mcode def) code
- | Ast0.Case(case,exp,colon,code) ->
- let exp = expression exp in
- let code = dots is_stm_dots (Some(promote_mcode colon)) statement code in
- mkres c (Ast0.Case(case,exp,colon,code)) (promote_mcode case) code
- | Ast0.OptCase(case) ->
- let case = case_line case in mkres c (Ast0.OptCase(case)) case case
-
-and statement_dots x = dots is_stm_dots None statement x
-
-(* --------------------------------------------------------------------- *)
-(* Function declaration *)
-
-let top_level t =
- match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) -> t
- | Ast0.DECL(stmt) ->
- let stmt = statement stmt in mkres t (Ast0.DECL(stmt)) stmt stmt
- | Ast0.CODE(rule_elem_dots) ->
- let rule_elem_dots = dots is_stm_dots None statement rule_elem_dots in
- mkres t (Ast0.CODE(rule_elem_dots)) rule_elem_dots rule_elem_dots
- | Ast0.ERRORWORDS(exps) -> t
- | Ast0.OTHER(_) -> failwith "eliminated by top_level"
-
-(* --------------------------------------------------------------------- *)
-(* Entry points *)
-
-let compute_lines = List.map top_level
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Detects subtrees that are all minus/plus and nodes that are "binding
-context nodes". The latter is a node whose structure and immediate tokens
-are the same in the minus and plus trees, and such that for every child,
-the set of context nodes in the child subtree is the same in the minus and
-plus subtrees. *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module V0 = Visitor_ast0
-module U = Unparse_ast0
-
-(* --------------------------------------------------------------------- *)
-(* Generic access to code *)
-
-let set_mcodekind x mcodekind =
- match x with
- Ast0.DotsExprTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsInitTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsParamTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsStmtTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsDeclTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsCaseTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.IdentTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.ExprTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.ParamTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DeclTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.InitTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.StmtTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.CaseLineTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.TopTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
-
-let set_index x index =
- match x with
- Ast0.DotsExprTag(d) -> Ast0.set_index d index
- | Ast0.DotsInitTag(d) -> Ast0.set_index d index
- | Ast0.DotsParamTag(d) -> Ast0.set_index d index
- | Ast0.DotsStmtTag(d) -> Ast0.set_index d index
- | Ast0.DotsDeclTag(d) -> Ast0.set_index d index
- | Ast0.DotsCaseTag(d) -> Ast0.set_index d index
- | Ast0.IdentTag(d) -> Ast0.set_index d index
- | Ast0.ExprTag(d) -> Ast0.set_index d index
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Ast0.set_index d index
- | Ast0.ParamTag(d) -> Ast0.set_index d index
- | Ast0.InitTag(d) -> Ast0.set_index d index
- | Ast0.DeclTag(d) -> Ast0.set_index d index
- | Ast0.StmtTag(d) -> Ast0.set_index d index
- | Ast0.CaseLineTag(d) -> Ast0.set_index d index
- | Ast0.TopTag(d) -> Ast0.set_index d index
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
-
-let get_index = function
- Ast0.DotsExprTag(d) -> Index.expression_dots d
- | Ast0.DotsInitTag(d) -> Index.initialiser_dots d
- | Ast0.DotsParamTag(d) -> Index.parameter_dots d
- | Ast0.DotsStmtTag(d) -> Index.statement_dots d
- | Ast0.DotsDeclTag(d) -> Index.declaration_dots d
- | Ast0.DotsCaseTag(d) -> Index.case_line_dots d
- | Ast0.IdentTag(d) -> Index.ident d
- | Ast0.ExprTag(d) -> Index.expression d
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Index.typeC d
- | Ast0.ParamTag(d) -> Index.parameterTypeDef d
- | Ast0.InitTag(d) -> Index.initialiser d
- | Ast0.DeclTag(d) -> Index.declaration d
- | Ast0.StmtTag(d) -> Index.statement d
- | Ast0.CaseLineTag(d) -> Index.case_line d
- | Ast0.TopTag(d) -> Index.top_level d
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
-
-(* --------------------------------------------------------------------- *)
-(* Collect the line numbers of the plus code. This is used for disjunctions.
-It is not completely clear why this is necessary, but it seems like an easy
-fix for whatever is the problem that is discussed in disj_cases *)
-
-let plus_lines = ref ([] : int list)
-
-let insert n =
- let rec loop = function
- [] -> [n]
- | x::xs ->
- match compare n x with
- 1 -> x::(loop xs)
- | 0 -> x::xs
- | -1 -> n::x::xs
- | _ -> failwith "not possible" in
- plus_lines := loop !plus_lines
-
-let find n min max =
- let rec loop = function
- [] -> (min,max)
- | [x] -> if n < x then (min,x) else (x,max)
- | x1::x2::rest ->
- if n < x1
- then (min,x1)
- else if n > x1 && n < x2 then (x1,x2) else loop (x2::rest) in
- loop !plus_lines
-
-let collect_plus_lines top =
- plus_lines := [];
- let bind x y = () in
- let option_default = () in
- let donothing r k e = k e in
- let mcode (_,_,info,mcodekind,_) =
- match mcodekind with
- Ast0.PLUS -> insert info.Ast0.line_start
- | _ -> () in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
- fn.V0.combiner_top_level top
-
-(* --------------------------------------------------------------------- *)
-
-type kind = Neutral | AllMarked | NotAllMarked (* marked means + or - *)
-
-(* --------------------------------------------------------------------- *)
-(* The first part analyzes each of the minus tree and the plus tree
-separately *)
-
-(* ints are unique token indices (offset field) *)
-type node =
- Token (* tokens *) of kind * int (* unique index *) * Ast0.mcodekind *
- int list (* context tokens *)
- | Recursor (* children *) of kind *
- int list (* indices of all tokens at the level below *) *
- Ast0.mcodekind list (* tokens at the level below *) *
- int list
- | Bind (* neighbors *) of kind *
- int list (* indices of all tokens at current level *) *
- Ast0.mcodekind list (* tokens at current level *) *
- int list (* indices of all tokens at the level below *) *
- Ast0.mcodekind list (* tokens at the level below *)
- * int list list
-
-let kind2c = function
- Neutral -> "neutral"
- | AllMarked -> "allmarked"
- | NotAllMarked -> "notallmarked"
-
-let node2c = function
- Token(k,_,_,_) -> Printf.sprintf "token %s\n" (kind2c k)
- | Recursor(k,_,_,_) -> Printf.sprintf "recursor %s\n" (kind2c k)
- | Bind(k,_,_,_,_,_) -> Printf.sprintf "bind %s\n" (kind2c k)
-
-(* goal: detect negative in both tokens and recursors, or context only in
-tokens *)
-let bind c1 c2 =
- let lub = function
- (k1,k2) when k1 = k2 -> k1
- | (Neutral,AllMarked) -> AllMarked
- | (AllMarked,Neutral) -> AllMarked
- | _ -> NotAllMarked in
- match (c1,c2) with
- (* token/token *)
- (* there are tokens at this level, so ignore the level below *)
- (Token(k1,i1,t1,l1),Token(k2,i2,t2,l2)) ->
- Bind(lub(k1,k2),[i1;i2],[t1;t2],[],[],[l1;l2])
-
- (* token/recursor *)
- (* there are tokens at this level, so ignore the level below *)
- | (Token(k1,i1,t1,l1),Recursor(k2,_,_,l2)) ->
- Bind(lub(k1,k2),[i1],[t1],[],[],[l1;l2])
- | (Recursor(k1,_,_,l1),Token(k2,i2,t2,l2)) ->
- Bind(lub(k1,k2),[i2],[t2],[],[],[l1;l2])
-
- (* token/bind *)
- (* there are tokens at this level, so ignore the level below *)
- | (Token(k1,i1,t1,l1),Bind(k2,i2,t2,_,_,l2)) ->
- Bind(lub(k1,k2),i1::i2,t1::t2,[],[],l1::l2)
- | (Bind(k1,i1,t1,_,_,l1),Token(k2,i2,t2,l2)) ->
- Bind(lub(k1,k2),i1@[i2],t1@[t2],[],[],l1@[l2])
-
- (* recursor/bind *)
- | (Recursor(k1,bi1,bt1,l1),Bind(k2,i2,t2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),i2,t2,bi1@bi2,bt1@bt2,l1::l2)
- | (Bind(k1,i1,t1,bi1,bt1,l1),Recursor(k2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),i1,t1,bi1@bi2,bt1@bt2,l1@[l2])
-
- (* recursor/recursor and bind/bind - not likely to ever occur *)
- | (Recursor(k1,bi1,bt1,l1),Recursor(k2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),[],[],bi1@bi2,bt1@bt2,[l1;l2])
- | (Bind(k1,i1,t1,bi1,bt1,l1),Bind(k2,i2,t2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),i1@i2,t1@t2,bi1@bi2,bt1@bt2,l1@l2)
-
-
-let option_default = (*Bind(Neutral,[],[],[],[],[])*)
- Recursor(Neutral,[],[],[])
-
-let mcode (_,_,info,mcodekind,pos) =
- let offset = info.Ast0.offset in
- match mcodekind with
- Ast0.MINUS(_) -> Token(AllMarked,offset,mcodekind,[])
- | Ast0.PLUS -> Token(AllMarked,offset,mcodekind,[])
- | Ast0.CONTEXT(_) -> Token(NotAllMarked,offset,mcodekind,[offset])
- | _ -> failwith "not possible"
-
-let neutral_mcode (_,_,info,mcodekind,pos) =
- let offset = info.Ast0.offset in
- match mcodekind with
- Ast0.MINUS(_) -> Token(Neutral,offset,mcodekind,[])
- | Ast0.PLUS -> Token(Neutral,offset,mcodekind,[])
- | Ast0.CONTEXT(_) -> Token(Neutral,offset,mcodekind,[offset])
- | _ -> failwith "not possible"
-
-let is_context = function Ast0.CONTEXT(_) -> true | _ -> false
-
-let union_all l = List.fold_left Common.union_set [] l
-
-(* is minus is true when we are processing minus code that might be
-intermingled with plus code. it is used in disj_cases *)
-let classify is_minus all_marked table code =
- let mkres builder k il tl bil btl l e =
- (if k = AllMarked
- then Ast0.set_mcodekind e (all_marked()) (* definitive *)
- else
- let check_index il tl =
- if List.for_all is_context tl
- then
- (let e1 = builder e in
- let index = (get_index e1)@il in
- try
- let _ = Hashtbl.find table index in
- failwith
- (Printf.sprintf "line %d: index %s already used\n"
- (Ast0.get_info e).Ast0.line_start
- (String.concat " " (List.map string_of_int index)))
- with Not_found -> Hashtbl.add table index (e1,l)) in
- if il = [] then check_index bil btl else check_index il tl);
- if il = []
- then Recursor(k, bil, btl, union_all l)
- else Recursor(k, il, tl, union_all l) in
-
- let compute_result builder e = function
- Bind(k,il,tl,bil,btl,l) -> mkres builder k il tl bil btl l e
- | Token(k,il,tl,l) -> mkres builder k [il] [tl] [] [] [l] e
- | Recursor(k,bil,btl,l) -> mkres builder k [] [] bil btl [l] e in
-
- let make_not_marked = function
- Bind(k,il,tl,bil,btl,l) -> Bind(NotAllMarked,il,tl,bil,btl,l)
- | Token(k,il,tl,l) -> Token(NotAllMarked,il,tl,l)
- | Recursor(k,bil,btl,l) -> Recursor(NotAllMarked,bil,btl,l) in
-
- let do_nothing builder r k e = compute_result builder e (k e) in
-
- let disj_cases disj starter code fn ender =
- (* neutral_mcode used so starter and ender don't have an affect on
- whether the code is considered all plus/minus, but so that they are
- consider in the index list, which is needed to make a disj with
- something in one branch and nothing in the other different from code
- that just has the something (starter/ender enough, mids not needed
- for this). Cannot agglomerate + code over | boundaries, because two -
- cases might have different + code, and don't want to put the + code
- together into one unit. *)
- let make_not_marked =
- if is_minus
- then
- (let min = Ast0.get_line disj in
- let max = Ast0.get_line_end disj in
- let (plus_min,plus_max) = find min (min-1) (max+1) in
- if max > plus_max then make_not_marked else (function x -> x))
- else make_not_marked in
- bind (neutral_mcode starter)
- (bind (List.fold_right bind
- (List.map make_not_marked (List.map fn code))
- option_default)
- (neutral_mcode ender)) in
-
- (* no whencode in plus tree so have to drop it *)
- (* need special cases for dots, nests, and disjs *)
- let expression r k e =
- compute_result Ast0.expr e
- (match Ast0.unwrap e with
- Ast0.NestExpr(starter,exp,ender,whencode,multi) ->
- k (Ast0.rewrap e (Ast0.NestExpr(starter,exp,ender,None,multi)))
- | Ast0.Edots(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Edots(dots,None)))
- | Ast0.Ecircles(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Ecircles(dots,None)))
- | Ast0.Estars(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Estars(dots,None)))
- | Ast0.DisjExpr(starter,expr_list,_,ender) ->
- disj_cases e starter expr_list r.V0.combiner_expression ender
- | _ -> k e) in
-
- (* not clear why we have the next two cases, since DisjDecl and
- DisjType shouldn't have been constructed yet, as they only come from isos *)
- let declaration r k e =
- compute_result Ast0.decl e
- (match Ast0.unwrap e with
- Ast0.DisjDecl(starter,decls,_,ender) ->
- disj_cases e starter decls r.V0.combiner_declaration ender
- | Ast0.Ddots(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Ddots(dots,None)))
- (* Need special cases for the following so that the type will be
- considered as a unit, rather than distributed around the
- declared variable. This needs to be done because of the call to
- compute_result, ie the processing of each term should make a
- side-effect on the complete term structure as well as collecting
- some information about it. So we have to visit each complete
- term structure. In (all?) other such cases, we visit the terms
- using rebuilder, which just visits the subterms, rather than
- reordering their components. *)
- | Ast0.Init(stg,ty,id,eq,ini,sem) ->
- bind (match stg with Some stg -> mcode stg | _ -> option_default)
- (bind (r.V0.combiner_typeC ty)
- (bind (r.V0.combiner_ident id)
- (bind (mcode eq)
- (bind (r.V0.combiner_initialiser ini) (mcode sem)))))
- | Ast0.UnInit(stg,ty,id,sem) ->
- bind (match stg with Some stg -> mcode stg | _ -> option_default)
- (bind (r.V0.combiner_typeC ty)
- (bind (r.V0.combiner_ident id) (mcode sem)))
- | _ -> k e) in
-
- let param r k e =
- compute_result Ast0.param e
- (match Ast0.unwrap e with
- Ast0.Param(ty,Some id) ->
- (* needed for the same reason as in the Init and UnInit cases *)
- bind (r.V0.combiner_typeC ty) (r.V0.combiner_ident id)
- | _ -> k e) in
-
- let typeC r k e =
- compute_result Ast0.typeC e
- (match Ast0.unwrap e with
- Ast0.DisjType(starter,types,_,ender) ->
- disj_cases e starter types r.V0.combiner_typeC ender
- | _ -> k e) in
-
- let initialiser r k i =
- compute_result Ast0.ini i
- (match Ast0.unwrap i with
- Ast0.Idots(dots,whencode) ->
- k (Ast0.rewrap i (Ast0.Idots(dots,None)))
- | _ -> k i) in
-
- let statement r k s =
- compute_result Ast0.stmt s
- (match Ast0.unwrap s with
- Ast0.Nest(started,stm_dots,ender,whencode,multi) ->
- k (Ast0.rewrap s (Ast0.Nest(started,stm_dots,ender,[],multi)))
- | Ast0.Dots(dots,whencode) ->
- k (Ast0.rewrap s (Ast0.Dots(dots,[])))
- | Ast0.Circles(dots,whencode) ->
- k (Ast0.rewrap s (Ast0.Circles(dots,[])))
- | Ast0.Stars(dots,whencode) ->
- k (Ast0.rewrap s (Ast0.Stars(dots,[])))
- | Ast0.Disj(starter,statement_dots_list,_,ender) ->
- disj_cases s starter statement_dots_list r.V0.combiner_statement_dots
- ender
-(* Why? There is nothing there
- (* cases for everything with extra mcode *)
- | Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
- | Ast0.Decl((info,bef),_) ->
- bind (mcode ((),(),info,bef)) (k s)
- | Ast0.IfThen(_,_,_,_,_,(info,aft))
- | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
- | Ast0.While(_,_,_,_,_,(info,aft)) ->
- | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft)) ->
- bind (k s) (mcode ((),(),info,aft))
- | Ast0.Iterator(_,_,_,_,_,(info,aft))
-*)
- | _ -> k s
-
-) in
-
- let do_top builder r k e = compute_result builder e (k e) in
-
- let combiner =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- (do_nothing Ast0.dotsExpr) (do_nothing Ast0.dotsInit)
- (do_nothing Ast0.dotsParam) (do_nothing Ast0.dotsStmt)
- (do_nothing Ast0.dotsDecl) (do_nothing Ast0.dotsCase)
- (do_nothing Ast0.ident) expression typeC initialiser param declaration
- statement (do_nothing Ast0.case_line) (do_top Ast0.top) in
- combiner.V0.combiner_top_level code
-
-(* --------------------------------------------------------------------- *)
-(* Traverse the hash tables and find corresponding context nodes that have
-the same context children *)
-
-(* this is just a sanity check - really only need to look at the top-level
- structure *)
-let equal_mcode (_,_,info1,_,_) (_,_,info2,_,_) =
- info1.Ast0.offset = info2.Ast0.offset
-
-let equal_option e1 e2 =
- match (e1,e2) with
- (Some x, Some y) -> equal_mcode x y
- | (None, None) -> true
- | _ -> false
-
-let dots fn d1 d2 =
- match (Ast0.unwrap d1,Ast0.unwrap d2) with
- (Ast0.DOTS(l1),Ast0.DOTS(l2)) -> List.length l1 = List.length l2
- | (Ast0.CIRCLES(l1),Ast0.CIRCLES(l2)) -> List.length l1 = List.length l2
- | (Ast0.STARS(l1),Ast0.STARS(l2)) -> List.length l1 = List.length l2
- | _ -> false
-
-let rec equal_ident i1 i2 =
- match (Ast0.unwrap i1,Ast0.unwrap i2) with
- (Ast0.Id(name1),Ast0.Id(name2)) -> equal_mcode name1 name2
- | (Ast0.MetaId(name1,_,_),Ast0.MetaId(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.MetaFunc(name1,_,_),Ast0.MetaFunc(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.MetaLocalFunc(name1,_,_),Ast0.MetaLocalFunc(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.OptIdent(_),Ast0.OptIdent(_)) -> true
- | (Ast0.UniqueIdent(_),Ast0.UniqueIdent(_)) -> true
- | _ -> false
-
-let rec equal_expression e1 e2 =
- match (Ast0.unwrap e1,Ast0.unwrap e2) with
- (Ast0.Ident(_),Ast0.Ident(_)) -> true
- | (Ast0.Constant(const1),Ast0.Constant(const2)) -> equal_mcode const1 const2
- | (Ast0.FunCall(_,lp1,_,rp1),Ast0.FunCall(_,lp2,_,rp2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.Assignment(_,op1,_,_),Ast0.Assignment(_,op2,_,_)) ->
- equal_mcode op1 op2
- | (Ast0.CondExpr(_,why1,_,colon1,_),Ast0.CondExpr(_,why2,_,colon2,_)) ->
- equal_mcode why1 why2 && equal_mcode colon1 colon2
- | (Ast0.Postfix(_,op1),Ast0.Postfix(_,op2)) -> equal_mcode op1 op2
- | (Ast0.Infix(_,op1),Ast0.Infix(_,op2)) -> equal_mcode op1 op2
- | (Ast0.Unary(_,op1),Ast0.Unary(_,op2)) -> equal_mcode op1 op2
- | (Ast0.Binary(_,op1,_),Ast0.Binary(_,op2,_)) -> equal_mcode op1 op2
- | (Ast0.Paren(lp1,_,rp1),Ast0.Paren(lp2,_,rp2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.ArrayAccess(_,lb1,_,rb1),Ast0.ArrayAccess(_,lb2,_,rb2)) ->
- equal_mcode lb1 lb2 && equal_mcode rb1 rb2
- | (Ast0.RecordAccess(_,pt1,_),Ast0.RecordAccess(_,pt2,_)) ->
- equal_mcode pt1 pt2
- | (Ast0.RecordPtAccess(_,ar1,_),Ast0.RecordPtAccess(_,ar2,_)) ->
- equal_mcode ar1 ar2
- | (Ast0.Cast(lp1,_,rp1,_),Ast0.Cast(lp2,_,rp2,_)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.SizeOfExpr(szf1,_),Ast0.SizeOfExpr(szf2,_)) ->
- equal_mcode szf1 szf2
- | (Ast0.SizeOfType(szf1,lp1,_,rp1),Ast0.SizeOfType(szf2,lp2,_,rp2)) ->
- equal_mcode szf1 szf2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.TypeExp(_),Ast0.TypeExp(_)) -> true
- | (Ast0.MetaErr(name1,_,_),Ast0.MetaErr(name2,_,_))
- | (Ast0.MetaExpr(name1,_,_,_,_),Ast0.MetaExpr(name2,_,_,_,_))
- | (Ast0.MetaExprList(name1,_,_),Ast0.MetaExprList(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.EComma(cm1),Ast0.EComma(cm2)) -> equal_mcode cm1 cm2
- | (Ast0.DisjExpr(starter1,_,mids1,ender1),
- Ast0.DisjExpr(starter2,_,mids2,ender2)) ->
- equal_mcode starter1 starter2 &&
- List.for_all2 equal_mcode mids1 mids2 &&
- equal_mcode ender1 ender2
- | (Ast0.NestExpr(starter1,_,ender1,_,m1),
- Ast0.NestExpr(starter2,_,ender2,_,m2)) ->
- equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
- | (Ast0.Edots(dots1,_),Ast0.Edots(dots2,_))
- | (Ast0.Ecircles(dots1,_),Ast0.Ecircles(dots2,_))
- | (Ast0.Estars(dots1,_),Ast0.Estars(dots2,_)) -> equal_mcode dots1 dots2
- | (Ast0.OptExp(_),Ast0.OptExp(_)) -> true
- | (Ast0.UniqueExp(_),Ast0.UniqueExp(_)) -> true
- | _ -> false
-
-let rec equal_typeC t1 t2 =
- match (Ast0.unwrap t1,Ast0.unwrap t2) with
- (Ast0.ConstVol(cv1,_),Ast0.ConstVol(cv2,_)) -> equal_mcode cv1 cv2
- | (Ast0.BaseType(ty1,stringsa),Ast0.BaseType(ty2,stringsb)) ->
- List.for_all2 equal_mcode stringsa stringsb
- | (Ast0.Signed(sign1,_),Ast0.Signed(sign2,_)) ->
- equal_mcode sign1 sign2
- | (Ast0.Pointer(_,star1),Ast0.Pointer(_,star2)) ->
- equal_mcode star1 star2
- | (Ast0.Array(_,lb1,_,rb1),Ast0.Array(_,lb2,_,rb2)) ->
- equal_mcode lb1 lb2 && equal_mcode rb1 rb2
- | (Ast0.EnumName(kind1,_),Ast0.EnumName(kind2,_)) ->
- equal_mcode kind1 kind2
- | (Ast0.StructUnionName(kind1,_),Ast0.StructUnionName(kind2,_)) ->
- equal_mcode kind1 kind2
- | (Ast0.FunctionType(ty1,lp1,p1,rp1),Ast0.FunctionType(ty2,lp2,p2,rp2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.StructUnionDef(_,lb1,_,rb1),
- Ast0.StructUnionDef(_,lb2,_,rb2)) ->
- equal_mcode lb1 lb2 && equal_mcode rb1 rb2
- | (Ast0.TypeName(name1),Ast0.TypeName(name2)) -> equal_mcode name1 name2
- | (Ast0.MetaType(name1,_),Ast0.MetaType(name2,_)) ->
- equal_mcode name1 name2
- | (Ast0.DisjType(starter1,_,mids1,ender1),
- Ast0.DisjType(starter2,_,mids2,ender2)) ->
- equal_mcode starter1 starter2 &&
- List.for_all2 equal_mcode mids1 mids2 &&
- equal_mcode ender1 ender2
- | (Ast0.OptType(_),Ast0.OptType(_)) -> true
- | (Ast0.UniqueType(_),Ast0.UniqueType(_)) -> true
- | _ -> false
-
-let equal_declaration d1 d2 =
- match (Ast0.unwrap d1,Ast0.unwrap d2) with
- (Ast0.Init(stg1,_,_,eq1,_,sem1),Ast0.Init(stg2,_,_,eq2,_,sem2)) ->
- equal_option stg1 stg2 && equal_mcode eq1 eq2 && equal_mcode sem1 sem2
- | (Ast0.UnInit(stg1,_,_,sem1),Ast0.UnInit(stg2,_,_,sem2)) ->
- equal_option stg1 stg2 && equal_mcode sem1 sem2
- | (Ast0.MacroDecl(nm1,lp1,_,rp1,sem1),Ast0.MacroDecl(nm2,lp2,_,rp2,sem2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
- | (Ast0.TyDecl(_,sem1),Ast0.TyDecl(_,sem2)) -> equal_mcode sem1 sem2
- | (Ast0.Ddots(dots1,_),Ast0.Ddots(dots2,_)) -> equal_mcode dots1 dots2
- | (Ast0.OptDecl(_),Ast0.OptDecl(_)) -> true
- | (Ast0.UniqueDecl(_),Ast0.UniqueDecl(_)) -> true
- | (Ast0.DisjDecl _,_) | (_,Ast0.DisjDecl _) ->
- failwith "DisjDecl not expected here"
- | _ -> false
-
-let equal_initialiser i1 i2 =
- match (Ast0.unwrap i1,Ast0.unwrap i2) with
- (Ast0.InitExpr(_),Ast0.InitExpr(_)) -> true
- | (Ast0.InitList(lb1,_,rb1),Ast0.InitList(lb2,_,rb2)) ->
- (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
- | (Ast0.InitGccDotName(dot1,_,eq1,_),Ast0.InitGccDotName(dot2,_,eq2,_)) ->
- (equal_mcode dot1 dot2) && (equal_mcode eq1 eq2)
- | (Ast0.InitGccName(_,eq1,_),Ast0.InitGccName(_,eq2,_)) ->
- equal_mcode eq1 eq2
- | (Ast0.InitGccIndex(lb1,_,rb1,eq1,_),Ast0.InitGccIndex(lb2,_,rb2,eq2,_)) ->
- (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2) && (equal_mcode eq1 eq2)
- | (Ast0.InitGccRange(lb1,_,dots1,_,rb1,eq1,_),
- Ast0.InitGccRange(lb2,_,dots2,_,rb2,eq2,_)) ->
- (equal_mcode lb1 lb2) && (equal_mcode dots1 dots2) &&
- (equal_mcode rb1 rb2) && (equal_mcode eq1 eq2)
- | (Ast0.IComma(cm1),Ast0.IComma(cm2)) -> equal_mcode cm1 cm2
- | (Ast0.Idots(d1,_),Ast0.Idots(d2,_)) -> equal_mcode d1 d2
- | (Ast0.OptIni(_),Ast0.OptIni(_)) -> true
- | (Ast0.UniqueIni(_),Ast0.UniqueIni(_)) -> true
- | _ -> false
-
-let equal_parameterTypeDef p1 p2 =
- match (Ast0.unwrap p1,Ast0.unwrap p2) with
- (Ast0.VoidParam(_),Ast0.VoidParam(_)) -> true
- | (Ast0.Param(_,_),Ast0.Param(_,_)) -> true
- | (Ast0.MetaParam(name1,_),Ast0.MetaParam(name2,_))
- | (Ast0.MetaParamList(name1,_,_),Ast0.MetaParamList(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.PComma(cm1),Ast0.PComma(cm2)) -> equal_mcode cm1 cm2
- | (Ast0.Pdots(dots1),Ast0.Pdots(dots2))
- | (Ast0.Pcircles(dots1),Ast0.Pcircles(dots2)) -> equal_mcode dots1 dots2
- | (Ast0.OptParam(_),Ast0.OptParam(_)) -> true
- | (Ast0.UniqueParam(_),Ast0.UniqueParam(_)) -> true
- | _ -> false
-
-let rec equal_statement s1 s2 =
- match (Ast0.unwrap s1,Ast0.unwrap s2) with
- (Ast0.FunDecl(_,fninfo1,_,lp1,_,rp1,lbrace1,_,rbrace1),
- Ast0.FunDecl(_,fninfo2,_,lp2,_,rp2,lbrace2,_,rbrace2)) ->
- (List.length fninfo1) = (List.length fninfo2) &&
- List.for_all2 equal_fninfo fninfo1 fninfo2 &&
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 &&
- equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
- | (Ast0.Decl(_,_),Ast0.Decl(_,_)) -> true
- | (Ast0.Seq(lbrace1,_,rbrace1),Ast0.Seq(lbrace2,_,rbrace2)) ->
- equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
- | (Ast0.ExprStatement(_,sem1),Ast0.ExprStatement(_,sem2)) ->
- equal_mcode sem1 sem2
- | (Ast0.IfThen(iff1,lp1,_,rp1,_,_),Ast0.IfThen(iff2,lp2,_,rp2,_,_)) ->
- equal_mcode iff1 iff2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.IfThenElse(iff1,lp1,_,rp1,_,els1,_,_),
- Ast0.IfThenElse(iff2,lp2,_,rp2,_,els2,_,_)) ->
- equal_mcode iff1 iff2 &&
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode els1 els2
- | (Ast0.While(whl1,lp1,_,rp1,_,_),Ast0.While(whl2,lp2,_,rp2,_,_)) ->
- equal_mcode whl1 whl2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.Do(d1,_,whl1,lp1,_,rp1,sem1),Ast0.Do(d2,_,whl2,lp2,_,rp2,sem2)) ->
- equal_mcode whl1 whl2 && equal_mcode d1 d2 &&
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
- | (Ast0.For(fr1,lp1,_,sem11,_,sem21,_,rp1,_,_),
- Ast0.For(fr2,lp2,_,sem12,_,sem22,_,rp2,_,_)) ->
- equal_mcode fr1 fr2 && equal_mcode lp1 lp2 &&
- equal_mcode sem11 sem12 && equal_mcode sem21 sem22 &&
- equal_mcode rp1 rp2
- | (Ast0.Iterator(nm1,lp1,_,rp1,_,_),Ast0.Iterator(nm2,lp2,_,rp2,_,_)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.Switch(switch1,lp1,_,rp1,lb1,case1,rb1),
- Ast0.Switch(switch2,lp2,_,rp2,lb2,case2,rb2)) ->
- equal_mcode switch1 switch2 && equal_mcode lp1 lp2 &&
- equal_mcode rp1 rp2 && equal_mcode lb1 lb2 &&
- equal_mcode rb1 rb2
- | (Ast0.Break(br1,sem1),Ast0.Break(br2,sem2)) ->
- equal_mcode br1 br2 && equal_mcode sem1 sem2
- | (Ast0.Continue(cont1,sem1),Ast0.Continue(cont2,sem2)) ->
- equal_mcode cont1 cont2 && equal_mcode sem1 sem2
- | (Ast0.Label(_,dd1),Ast0.Label(_,dd2)) ->
- equal_mcode dd1 dd2
- | (Ast0.Goto(g1,_,sem1),Ast0.Goto(g2,_,sem2)) ->
- equal_mcode g1 g2 && equal_mcode sem1 sem2
- | (Ast0.Return(ret1,sem1),Ast0.Return(ret2,sem2)) ->
- equal_mcode ret1 ret2 && equal_mcode sem1 sem2
- | (Ast0.ReturnExpr(ret1,_,sem1),Ast0.ReturnExpr(ret2,_,sem2)) ->
- equal_mcode ret1 ret2 && equal_mcode sem1 sem2
- | (Ast0.MetaStmt(name1,_),Ast0.MetaStmt(name2,_))
- | (Ast0.MetaStmtList(name1,_),Ast0.MetaStmtList(name2,_)) ->
- equal_mcode name1 name2
- | (Ast0.Disj(starter1,_,mids1,ender1),Ast0.Disj(starter2,_,mids2,ender2)) ->
- equal_mcode starter1 starter2 &&
- List.for_all2 equal_mcode mids1 mids2 &&
- equal_mcode ender1 ender2
- | (Ast0.Nest(starter1,_,ender1,_,m1),Ast0.Nest(starter2,_,ender2,_,m2)) ->
- equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
- | (Ast0.Exp(_),Ast0.Exp(_)) -> true
- | (Ast0.TopExp(_),Ast0.TopExp(_)) -> true
- | (Ast0.Ty(_),Ast0.Ty(_)) -> true
- | (Ast0.TopInit(_),Ast0.TopInit(_)) -> true
- | (Ast0.Dots(d1,_),Ast0.Dots(d2,_))
- | (Ast0.Circles(d1,_),Ast0.Circles(d2,_))
- | (Ast0.Stars(d1,_),Ast0.Stars(d2,_)) -> equal_mcode d1 d2
- | (Ast0.Include(inc1,name1),Ast0.Include(inc2,name2)) ->
- equal_mcode inc1 inc2 && equal_mcode name1 name2
- | (Ast0.Define(def1,_,_,_),Ast0.Define(def2,_,_,_)) ->
- equal_mcode def1 def2
- | (Ast0.OptStm(_),Ast0.OptStm(_)) -> true
- | (Ast0.UniqueStm(_),Ast0.UniqueStm(_)) -> true
- | _ -> false
-
-and equal_fninfo x y =
- match (x,y) with
- (Ast0.FStorage(s1),Ast0.FStorage(s2)) -> equal_mcode s1 s2
- | (Ast0.FType(_),Ast0.FType(_)) -> true
- | (Ast0.FInline(i1),Ast0.FInline(i2)) -> equal_mcode i1 i2
- | (Ast0.FAttr(i1),Ast0.FAttr(i2)) -> equal_mcode i1 i2
- | _ -> false
-
-let equal_case_line c1 c2 =
- match (Ast0.unwrap c1,Ast0.unwrap c2) with
- (Ast0.Default(def1,colon1,_),Ast0.Default(def2,colon2,_)) ->
- equal_mcode def1 def2 && equal_mcode colon1 colon2
- | (Ast0.Case(case1,_,colon1,_),Ast0.Case(case2,_,colon2,_)) ->
- equal_mcode case1 case2 && equal_mcode colon1 colon2
- | (Ast0.OptCase(_),Ast0.OptCase(_)) -> true
- | _ -> false
-
-let rec equal_top_level t1 t2 =
- match (Ast0.unwrap t1,Ast0.unwrap t2) with
- (Ast0.DECL(_),Ast0.DECL(_)) -> true
- | (Ast0.FILEINFO(old_file1,new_file1),Ast0.FILEINFO(old_file2,new_file2)) ->
- equal_mcode old_file1 old_file2 && equal_mcode new_file1 new_file2
- | (Ast0.CODE(_),Ast0.CODE(_)) -> true
- | (Ast0.ERRORWORDS(_),Ast0.ERRORWORDS(_)) -> true
- | _ -> false
-
-let root_equal e1 e2 =
- match (e1,e2) with
- (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) -> dots equal_expression d1 d2
- | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
- dots equal_parameterTypeDef d1 d2
- | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) -> dots equal_statement d1 d2
- | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) -> dots equal_declaration d1 d2
- | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) -> dots equal_case_line d1 d2
- | (Ast0.IdentTag(i1),Ast0.IdentTag(i2)) -> equal_ident i1 i2
- | (Ast0.ExprTag(e1),Ast0.ExprTag(e2)) -> equal_expression e1 e2
- | (Ast0.ArgExprTag(d),_) -> failwith "not possible - iso only"
- | (Ast0.TypeCTag(t1),Ast0.TypeCTag(t2)) -> equal_typeC t1 t2
- | (Ast0.ParamTag(p1),Ast0.ParamTag(p2)) -> equal_parameterTypeDef p1 p2
- | (Ast0.InitTag(d1),Ast0.InitTag(d2)) -> equal_initialiser d1 d2
- | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) -> equal_declaration d1 d2
- | (Ast0.StmtTag(s1),Ast0.StmtTag(s2)) -> equal_statement s1 s2
- | (Ast0.TopTag(t1),Ast0.TopTag(t2)) -> equal_top_level t1 t2
- | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_))
- | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_))
- | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
- failwith "only within iso phase"
- | _ -> false
-
-let default_context _ =
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info))
-
-let traverse minus_table plus_table =
- Hashtbl.iter
- (function key ->
- function (e,l) ->
- try
- let (plus_e,plus_l) = Hashtbl.find plus_table key in
- if root_equal e plus_e &&
- List.for_all (function x -> x)
- (List.map2 Common.equal_set l plus_l)
- then
- let i = Ast0.fresh_index() in
- (set_index e i; set_index plus_e i;
- set_mcodekind e (default_context());
- set_mcodekind plus_e (default_context()))
- with Not_found -> ())
- minus_table
-
-(* --------------------------------------------------------------------- *)
-(* contextify the whencode *)
-
-let contextify_all =
- let bind x y = () in
- let option_default = () in
- let mcode x = () in
- let do_nothing r k e = Ast0.set_mcodekind e (default_context()); k e in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing
-
-let contextify_whencode =
- let bind x y = () in
- let option_default = () in
- let mcode x = () in
- let do_nothing r k e = k e in
-
- let expression r k e =
- k e;
- match Ast0.unwrap e with
- Ast0.NestExpr(_,_,_,Some whencode,_)
- | Ast0.Edots(_,Some whencode)
- | Ast0.Ecircles(_,Some whencode)
- | Ast0.Estars(_,Some whencode) ->
- contextify_all.V0.combiner_expression whencode
- | _ -> () in
-
- let initialiser r k i =
- match Ast0.unwrap i with
- Ast0.Idots(dots,Some whencode) ->
- contextify_all.V0.combiner_initialiser whencode
- | _ -> k i in
-
- let whencode = function
- Ast0.WhenNot sd -> contextify_all.V0.combiner_statement_dots sd
- | Ast0.WhenAlways s -> contextify_all.V0.combiner_statement s
- | Ast0.WhenModifier(_) -> ()
- | Ast0.WhenNotTrue(e) -> contextify_all.V0.combiner_expression e
- | Ast0.WhenNotFalse(e) -> contextify_all.V0.combiner_expression e in
-
- let statement r k (s : Ast0.statement) =
- k s;
- match Ast0.unwrap s with
- Ast0.Nest(_,_,_,whn,_)
- | Ast0.Dots(_,whn) | Ast0.Circles(_,whn) | Ast0.Stars(_,whn) ->
- List.iter whencode whn
- | _ -> () in
-
- let combiner =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing
- expression
- do_nothing initialiser do_nothing do_nothing statement do_nothing
- do_nothing in
- combiner.V0.combiner_top_level
-
-(* --------------------------------------------------------------------- *)
-
-(* the first int list is the tokens in the node, the second is the tokens
-in the descendents *)
-let minus_table =
- (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
-let plus_table =
- (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
-
-let iscode t =
- match Ast0.unwrap t with
- Ast0.DECL(_) -> true
- | Ast0.FILEINFO(_) -> true
- | Ast0.ERRORWORDS(_) -> false
- | Ast0.CODE(_) -> true
- | Ast0.OTHER(_) -> failwith "unexpected top level code"
-
-(* ------------------------------------------------------------------- *)
-(* alignment of minus and plus *)
-
-let concat = function
- [] -> []
- | [s] -> [s]
- | l ->
- let rec loop = function
- [] -> []
- | x::rest ->
- (match Ast0.unwrap x with
- Ast0.DECL(s) -> let stms = loop rest in s::stms
- | Ast0.CODE(ss) ->
- let stms = loop rest in
- (match Ast0.unwrap ss with
- Ast0.DOTS(d) -> d@stms
- | _ -> failwith "no dots allowed in pure plus code")
- | _ -> failwith "plus code is being discarded") in
- let res =
- Compute_lines.statement_dots
- (Ast0.rewrap (List.hd l) (Ast0.DOTS (loop l))) in
- [Ast0.rewrap res (Ast0.CODE res)]
-
-let collect_up_to m plus =
- let minfo = Ast0.get_info m in
- let mend = minfo.Ast0.logical_end in
- let rec loop = function
- [] -> ([],[])
- | p::plus ->
- let pinfo = Ast0.get_info p in
- let pstart = pinfo.Ast0.logical_start in
- if pstart > mend
- then ([],p::plus)
- else let (plus,rest) = loop plus in (p::plus,rest) in
- let (plus,rest) = loop plus in
- (concat plus,rest)
-
-let realign minus plus =
- let rec loop = function
- ([],_) -> failwith "not possible, some context required"
- | ([m],p) -> ([m],concat p)
- | (m::minus,plus) ->
- let (p,plus) = collect_up_to m plus in
- let (minus,plus) = loop (minus,plus) in
- (m::minus,p@plus) in
- loop (minus,plus)
-
-(* ------------------------------------------------------------------- *)
-(* check compatible: check that at the top level the minus and plus code is
-of the same kind. Could go further and make the correspondence between the
-code between ...s. *)
-
-let isonly f l = match Ast0.undots l with [s] -> f s | _ -> false
-
-let isall f l = List.for_all (isonly f) l
-
-let rec is_exp s =
- match Ast0.unwrap s with
- Ast0.Exp(e) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_exp stmts
- | _ -> false
-
-let rec is_ty s =
- match Ast0.unwrap s with
- Ast0.Ty(e) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_ty stmts
- | _ -> false
-
-let rec is_init s =
- match Ast0.unwrap s with
- Ast0.TopInit(e) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_init stmts
- | _ -> false
-
-let rec is_decl s =
- match Ast0.unwrap s with
- Ast0.Decl(_,e) -> true
- | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_decl stmts
- | _ -> false
-
-let rec is_fndecl s =
- match Ast0.unwrap s with
- Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_fndecl stmts
- | _ -> false
-
-let rec is_toplevel s =
- match Ast0.unwrap s with
- Ast0.Decl(_,e) -> true
- | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_toplevel stmts
- | Ast0.ExprStatement(fc,_) ->
- (match Ast0.unwrap fc with
- Ast0.FunCall(_,_,_,_) -> true
- | _ -> false)
- | Ast0.Include(_,_) -> true
- | Ast0.Define(_,_,_,_) -> true
- | _ -> false
-
-let check_compatible m p =
- let fail _ =
- failwith
- (Printf.sprintf
- "incompatible minus and plus code starting on lines %d and %d"
- (Ast0.get_line m) (Ast0.get_line p)) in
- match (Ast0.unwrap m, Ast0.unwrap p) with
- (Ast0.DECL(decl1),Ast0.DECL(decl2)) ->
- if not (is_decl decl1 && is_decl decl2)
- then fail()
- | (Ast0.DECL(decl1),Ast0.CODE(code2)) ->
- let v1 = is_decl decl1 in
- let v2 = List.for_all is_toplevel (Ast0.undots code2) in
- if !Flag.make_hrule = None && v1 && not v2 then fail()
- | (Ast0.CODE(code1),Ast0.DECL(decl2)) ->
- let v1 = List.for_all is_toplevel (Ast0.undots code1) in
- let v2 = is_decl decl2 in
- if v1 && not v2 then fail()
- | (Ast0.CODE(code1),Ast0.CODE(code2)) ->
- let v1 = isonly is_init code1 in
- let v2a = isonly is_init code2 in
- let v2b = isonly is_exp code2 in
- if v1
- then (if not (v2a || v2b) then fail())
- else
- let testers = [is_exp;is_ty] in
- List.iter
- (function tester ->
- let v1 = isonly tester code1 in
- let v2 = isonly tester code2 in
- if (v1 && not v2) or (!Flag.make_hrule = None && v2 && not v1)
- then fail())
- testers;
- let v1 = isonly is_fndecl code1 in
- let v2 = List.for_all is_toplevel (Ast0.undots code2) in
- if !Flag.make_hrule = None && v1 && not v2 then fail()
- | (Ast0.FILEINFO(_,_),Ast0.FILEINFO(_,_)) -> ()
- | (Ast0.OTHER(_),Ast0.OTHER(_)) -> ()
- | _ -> fail()
-
-(* ------------------------------------------------------------------- *)
-
-(* returns a list of corresponding minus and plus trees *)
-let context_neg minus plus =
- Hashtbl.clear minus_table;
- Hashtbl.clear plus_table;
- List.iter contextify_whencode minus;
- let (minus,plus) = realign minus plus in
- let rec loop = function
- ([],[]) -> []
- | ([],l) ->
- failwith (Printf.sprintf "%d plus things remaining" (List.length l))
- | (minus,[]) ->
- plus_lines := [];
- let _ =
- List.map
- (function m ->
- classify true
- (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
- minus_table m)
- minus in
- []
- | (((m::minus) as mall),((p::plus) as pall)) ->
- let minfo = Ast0.get_info m in
- let pinfo = Ast0.get_info p in
- let mstart = minfo.Ast0.logical_start in
- let mend = minfo.Ast0.logical_end in
- let pstart = pinfo.Ast0.logical_start in
- let pend = pinfo.Ast0.logical_end in
- if (iscode m or iscode p) &&
- (mend + 1 = pstart or pend + 1 = mstart or (* adjacent *)
- (mstart <= pstart && mend >= pstart) or
- (pstart <= mstart && pend >= mstart)) (* overlapping or nested *)
- then
- begin
- (* ensure that the root of each tree has a unique index,
- although it might get overwritten if the node is a context
- node *)
- let i = Ast0.fresh_index() in
- Ast0.set_index m i; Ast0.set_index p i;
- check_compatible m p;
- collect_plus_lines p;
- let _ =
- classify true
- (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
- minus_table m in
- let _ = classify false (function _ -> Ast0.PLUS) plus_table p in
- traverse minus_table plus_table;
- (m,p)::loop(minus,plus)
- end
- else
- if not(iscode m or iscode p)
- then loop(minus,plus)
- else
- if mstart < pstart
- then
- begin
- plus_lines := [];
- let _ =
- classify true
- (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
- minus_table m in
- loop(minus,pall)
- end
- else loop(mall,plus) in
- loop(minus,plus)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Detects subtrees that are all minus/plus and nodes that are "binding
-context nodes". The latter is a node whose structure and immediate tokens
-are the same in the minus and plus trees, and such that for every child,
-the set of context nodes in the child subtree is the same in the minus and
-plus subtrees. *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module V0 = Visitor_ast0
-module U = Unparse_ast0
-
-(* --------------------------------------------------------------------- *)
-(* Generic access to code *)
-
-let set_mcodekind x mcodekind =
- match x with
- Ast0.DotsExprTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsInitTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsParamTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsStmtTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsDeclTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DotsCaseTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.IdentTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.ExprTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.ParamTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.DeclTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.InitTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.StmtTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.CaseLineTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.TopTag(d) -> Ast0.set_mcodekind d mcodekind
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
-
-let set_index x index =
- match x with
- Ast0.DotsExprTag(d) -> Ast0.set_index d index
- | Ast0.DotsInitTag(d) -> Ast0.set_index d index
- | Ast0.DotsParamTag(d) -> Ast0.set_index d index
- | Ast0.DotsStmtTag(d) -> Ast0.set_index d index
- | Ast0.DotsDeclTag(d) -> Ast0.set_index d index
- | Ast0.DotsCaseTag(d) -> Ast0.set_index d index
- | Ast0.IdentTag(d) -> Ast0.set_index d index
- | Ast0.ExprTag(d) -> Ast0.set_index d index
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Ast0.set_index d index
- | Ast0.ParamTag(d) -> Ast0.set_index d index
- | Ast0.InitTag(d) -> Ast0.set_index d index
- | Ast0.DeclTag(d) -> Ast0.set_index d index
- | Ast0.StmtTag(d) -> Ast0.set_index d index
- | Ast0.CaseLineTag(d) -> Ast0.set_index d index
- | Ast0.TopTag(d) -> Ast0.set_index d index
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
-
-let get_index = function
- Ast0.DotsExprTag(d) -> Index.expression_dots d
- | Ast0.DotsInitTag(d) -> Index.initialiser_dots d
- | Ast0.DotsParamTag(d) -> Index.parameter_dots d
- | Ast0.DotsStmtTag(d) -> Index.statement_dots d
- | Ast0.DotsDeclTag(d) -> Index.declaration_dots d
- | Ast0.DotsCaseTag(d) -> Index.case_line_dots d
- | Ast0.IdentTag(d) -> Index.ident d
- | Ast0.ExprTag(d) -> Index.expression d
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Index.typeC d
- | Ast0.ParamTag(d) -> Index.parameterTypeDef d
- | Ast0.InitTag(d) -> Index.initialiser d
- | Ast0.DeclTag(d) -> Index.declaration d
- | Ast0.StmtTag(d) -> Index.statement d
- | Ast0.CaseLineTag(d) -> Index.case_line d
- | Ast0.TopTag(d) -> Index.top_level d
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
-
-(* --------------------------------------------------------------------- *)
-(* Collect the line numbers of the plus code. This is used for disjunctions.
-It is not completely clear why this is necessary, but it seems like an easy
-fix for whatever is the problem that is discussed in disj_cases *)
-
-let plus_lines = ref ([] : int list)
-
-let insert n =
- let rec loop = function
- [] -> [n]
- | x::xs ->
- match compare n x with
- 1 -> x::(loop xs)
- | 0 -> x::xs
- | -1 -> n::x::xs
- | _ -> failwith "not possible" in
- plus_lines := loop !plus_lines
-
-let find n min max =
- let rec loop = function
- [] -> (min,max)
- | [x] -> if n < x then (min,x) else (x,max)
- | x1::x2::rest ->
- if n < x1
- then (min,x1)
- else if n > x1 && n < x2 then (x1,x2) else loop (x2::rest) in
- loop !plus_lines
-
-let collect_plus_lines top =
- plus_lines := [];
- let bind x y = () in
- let option_default = () in
- let donothing r k e = k e in
- let mcode (_,_,info,mcodekind,_) =
- match mcodekind with
- Ast0.PLUS -> insert info.Ast0.line_start
- | _ -> () in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
- fn.V0.combiner_top_level top
-
-(* --------------------------------------------------------------------- *)
-
-type kind = Neutral | AllMarked | NotAllMarked (* marked means + or - *)
-
-(* --------------------------------------------------------------------- *)
-(* The first part analyzes each of the minus tree and the plus tree
-separately *)
-
-(* ints are unique token indices (offset field) *)
-type node =
- Token (* tokens *) of kind * int (* unique index *) * Ast0.mcodekind *
- int list (* context tokens *)
- | Recursor (* children *) of kind *
- int list (* indices of all tokens at the level below *) *
- Ast0.mcodekind list (* tokens at the level below *) *
- int list
- | Bind (* neighbors *) of kind *
- int list (* indices of all tokens at current level *) *
- Ast0.mcodekind list (* tokens at current level *) *
- int list (* indices of all tokens at the level below *) *
- Ast0.mcodekind list (* tokens at the level below *)
- * int list list
-
-let kind2c = function
- Neutral -> "neutral"
- | AllMarked -> "allmarked"
- | NotAllMarked -> "notallmarked"
-
-let node2c = function
- Token(k,_,_,_) -> Printf.sprintf "token %s\n" (kind2c k)
- | Recursor(k,_,_,_) -> Printf.sprintf "recursor %s\n" (kind2c k)
- | Bind(k,_,_,_,_,_) -> Printf.sprintf "bind %s\n" (kind2c k)
-
-(* goal: detect negative in both tokens and recursors, or context only in
-tokens *)
-let bind c1 c2 =
- let lub = function
- (k1,k2) when k1 = k2 -> k1
- | (Neutral,AllMarked) -> AllMarked
- | (AllMarked,Neutral) -> AllMarked
- | _ -> NotAllMarked in
- match (c1,c2) with
- (* token/token *)
- (* there are tokens at this level, so ignore the level below *)
- (Token(k1,i1,t1,l1),Token(k2,i2,t2,l2)) ->
- Bind(lub(k1,k2),[i1;i2],[t1;t2],[],[],[l1;l2])
-
- (* token/recursor *)
- (* there are tokens at this level, so ignore the level below *)
- | (Token(k1,i1,t1,l1),Recursor(k2,_,_,l2)) ->
- Bind(lub(k1,k2),[i1],[t1],[],[],[l1;l2])
- | (Recursor(k1,_,_,l1),Token(k2,i2,t2,l2)) ->
- Bind(lub(k1,k2),[i2],[t2],[],[],[l1;l2])
-
- (* token/bind *)
- (* there are tokens at this level, so ignore the level below *)
- | (Token(k1,i1,t1,l1),Bind(k2,i2,t2,_,_,l2)) ->
- Bind(lub(k1,k2),i1::i2,t1::t2,[],[],l1::l2)
- | (Bind(k1,i1,t1,_,_,l1),Token(k2,i2,t2,l2)) ->
- Bind(lub(k1,k2),i1@[i2],t1@[t2],[],[],l1@[l2])
-
- (* recursor/bind *)
- | (Recursor(k1,bi1,bt1,l1),Bind(k2,i2,t2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),i2,t2,bi1@bi2,bt1@bt2,l1::l2)
- | (Bind(k1,i1,t1,bi1,bt1,l1),Recursor(k2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),i1,t1,bi1@bi2,bt1@bt2,l1@[l2])
-
- (* recursor/recursor and bind/bind - not likely to ever occur *)
- | (Recursor(k1,bi1,bt1,l1),Recursor(k2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),[],[],bi1@bi2,bt1@bt2,[l1;l2])
- | (Bind(k1,i1,t1,bi1,bt1,l1),Bind(k2,i2,t2,bi2,bt2,l2)) ->
- Bind(lub(k1,k2),i1@i2,t1@t2,bi1@bi2,bt1@bt2,l1@l2)
-
-
-let option_default = (*Bind(Neutral,[],[],[],[],[])*)
- Recursor(Neutral,[],[],[])
-
-let mcode (_,_,info,mcodekind,pos) =
- let offset = info.Ast0.offset in
- match mcodekind with
- Ast0.MINUS(_) -> Token(AllMarked,offset,mcodekind,[])
- | Ast0.PLUS -> Token(AllMarked,offset,mcodekind,[])
- | Ast0.CONTEXT(_) -> Token(NotAllMarked,offset,mcodekind,[offset])
- | _ -> failwith "not possible"
-
-let neutral_mcode (_,_,info,mcodekind,pos) =
- let offset = info.Ast0.offset in
- match mcodekind with
- Ast0.MINUS(_) -> Token(Neutral,offset,mcodekind,[])
- | Ast0.PLUS -> Token(Neutral,offset,mcodekind,[])
- | Ast0.CONTEXT(_) -> Token(Neutral,offset,mcodekind,[offset])
- | _ -> failwith "not possible"
-
-let is_context = function Ast0.CONTEXT(_) -> true | _ -> false
-
-let union_all l = List.fold_left Common.union_set [] l
-
-(* is minus is true when we are processing minus code that might be
-intermingled with plus code. it is used in disj_cases *)
-let classify is_minus all_marked table code =
- let mkres builder k il tl bil btl l e =
- (if k = AllMarked
- then Ast0.set_mcodekind e (all_marked()) (* definitive *)
- else
- let check_index il tl =
- if List.for_all is_context tl
- then
- (let e1 = builder e in
- let index = (get_index e1)@il in
- try
- let _ = Hashtbl.find table index in
- failwith
- (Printf.sprintf "line %d: index %s already used\n"
- (Ast0.get_info e).Ast0.line_start
- (String.concat " " (List.map string_of_int index)))
- with Not_found -> Hashtbl.add table index (e1,l)) in
- if il = [] then check_index bil btl else check_index il tl);
- if il = []
- then Recursor(k, bil, btl, union_all l)
- else Recursor(k, il, tl, union_all l) in
-
- let compute_result builder e = function
- Bind(k,il,tl,bil,btl,l) -> mkres builder k il tl bil btl l e
- | Token(k,il,tl,l) -> mkres builder k [il] [tl] [] [] [l] e
- | Recursor(k,bil,btl,l) -> mkres builder k [] [] bil btl [l] e in
-
- let make_not_marked = function
- Bind(k,il,tl,bil,btl,l) -> Bind(NotAllMarked,il,tl,bil,btl,l)
- | Token(k,il,tl,l) -> Token(NotAllMarked,il,tl,l)
- | Recursor(k,bil,btl,l) -> Recursor(NotAllMarked,bil,btl,l) in
-
- let do_nothing builder r k e = compute_result builder e (k e) in
-
- let disj_cases disj starter code fn ender =
- (* neutral_mcode used so starter and ender don't have an affect on
- whether the code is considered all plus/minus, but so that they are
- consider in the index list, which is needed to make a disj with
- something in one branch and nothing in the other different from code
- that just has the something (starter/ender enough, mids not needed
- for this). Cannot agglomerate + code over | boundaries, because two -
- cases might have different + code, and don't want to put the + code
- together into one unit. *)
- let make_not_marked =
- if is_minus
- then
- (let min = Ast0.get_line disj in
- let max = Ast0.get_line_end disj in
- let (plus_min,plus_max) = find min (min-1) (max+1) in
- if max > plus_max then make_not_marked else (function x -> x))
- else make_not_marked in
- bind (neutral_mcode starter)
- (bind (List.fold_right bind
- (List.map make_not_marked (List.map fn code))
- option_default)
- (neutral_mcode ender)) in
-
- (* no whencode in plus tree so have to drop it *)
- (* need special cases for dots, nests, and disjs *)
- let expression r k e =
- compute_result Ast0.expr e
- (match Ast0.unwrap e with
- Ast0.NestExpr(starter,exp,ender,whencode,multi) ->
- k (Ast0.rewrap e (Ast0.NestExpr(starter,exp,ender,None,multi)))
- | Ast0.Edots(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Edots(dots,None)))
- | Ast0.Ecircles(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Ecircles(dots,None)))
- | Ast0.Estars(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Estars(dots,None)))
- | Ast0.DisjExpr(starter,expr_list,_,ender) ->
- disj_cases e starter expr_list r.V0.combiner_expression ender
- | _ -> k e) in
-
- (* not clear why we have the next two cases, since DisjDecl and
- DisjType shouldn't have been constructed yet, as they only come from isos *)
- let declaration r k e =
- compute_result Ast0.decl e
- (match Ast0.unwrap e with
- Ast0.DisjDecl(starter,decls,_,ender) ->
- disj_cases e starter decls r.V0.combiner_declaration ender
- | Ast0.Ddots(dots,whencode) ->
- k (Ast0.rewrap e (Ast0.Ddots(dots,None)))
- (* Need special cases for the following so that the type will be
- considered as a unit, rather than distributed around the
- declared variable. This needs to be done because of the call to
- compute_result, ie the processing of each term should make a
- side-effect on the complete term structure as well as collecting
- some information about it. So we have to visit each complete
- term structure. In (all?) other such cases, we visit the terms
- using rebuilder, which just visits the subterms, rather than
- reordering their components. *)
- | Ast0.Init(stg,ty,id,eq,ini,sem) ->
- bind (match stg with Some stg -> mcode stg | _ -> option_default)
- (bind (r.V0.combiner_typeC ty)
- (bind (r.V0.combiner_ident id)
- (bind (mcode eq)
- (bind (r.V0.combiner_initialiser ini) (mcode sem)))))
- | Ast0.UnInit(stg,ty,id,sem) ->
- bind (match stg with Some stg -> mcode stg | _ -> option_default)
- (bind (r.V0.combiner_typeC ty)
- (bind (r.V0.combiner_ident id) (mcode sem)))
- | _ -> k e) in
-
- let param r k e =
- compute_result Ast0.param e
- (match Ast0.unwrap e with
- Ast0.Param(ty,Some id) ->
- (* needed for the same reason as in the Init and UnInit cases *)
- bind (r.V0.combiner_typeC ty) (r.V0.combiner_ident id)
- | _ -> k e) in
-
- let typeC r k e =
- compute_result Ast0.typeC e
- (match Ast0.unwrap e with
- Ast0.DisjType(starter,types,_,ender) ->
- disj_cases e starter types r.V0.combiner_typeC ender
- | _ -> k e) in
-
- let initialiser r k i =
- compute_result Ast0.ini i
- (match Ast0.unwrap i with
- Ast0.Idots(dots,whencode) ->
- k (Ast0.rewrap i (Ast0.Idots(dots,None)))
- | _ -> k i) in
-
- let statement r k s =
- compute_result Ast0.stmt s
- (match Ast0.unwrap s with
- Ast0.Nest(started,stm_dots,ender,whencode,multi) ->
- k (Ast0.rewrap s (Ast0.Nest(started,stm_dots,ender,[],multi)))
- | Ast0.Dots(dots,whencode) ->
- k (Ast0.rewrap s (Ast0.Dots(dots,[])))
- | Ast0.Circles(dots,whencode) ->
- k (Ast0.rewrap s (Ast0.Circles(dots,[])))
- | Ast0.Stars(dots,whencode) ->
- k (Ast0.rewrap s (Ast0.Stars(dots,[])))
- | Ast0.Disj(starter,statement_dots_list,_,ender) ->
- disj_cases s starter statement_dots_list r.V0.combiner_statement_dots
- ender
-(* Why? There is nothing there
- (* cases for everything with extra mcode *)
- | Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
- | Ast0.Decl((info,bef),_) ->
- bind (mcode ((),(),info,bef)) (k s)
- | Ast0.IfThen(_,_,_,_,_,(info,aft))
- | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
- | Ast0.While(_,_,_,_,_,(info,aft)) ->
- | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft)) ->
- bind (k s) (mcode ((),(),info,aft))
- | Ast0.Iterator(_,_,_,_,_,(info,aft))
-*)
- | _ -> k s
-
-) in
-
- let do_top builder r k e = compute_result builder e (k e) in
-
- let combiner =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- (do_nothing Ast0.dotsExpr) (do_nothing Ast0.dotsInit)
- (do_nothing Ast0.dotsParam) (do_nothing Ast0.dotsStmt)
- (do_nothing Ast0.dotsDecl) (do_nothing Ast0.dotsCase)
- (do_nothing Ast0.ident) expression typeC initialiser param declaration
- statement (do_nothing Ast0.case_line) (do_top Ast0.top) in
- combiner.V0.combiner_top_level code
-
-(* --------------------------------------------------------------------- *)
-(* Traverse the hash tables and find corresponding context nodes that have
-the same context children *)
-
-(* this is just a sanity check - really only need to look at the top-level
- structure *)
-let equal_mcode (_,_,info1,_,_) (_,_,info2,_,_) =
- info1.Ast0.offset = info2.Ast0.offset
-
-let equal_option e1 e2 =
- match (e1,e2) with
- (Some x, Some y) -> equal_mcode x y
- | (None, None) -> true
- | _ -> false
-
-let dots fn d1 d2 =
- match (Ast0.unwrap d1,Ast0.unwrap d2) with
- (Ast0.DOTS(l1),Ast0.DOTS(l2)) -> List.length l1 = List.length l2
- | (Ast0.CIRCLES(l1),Ast0.CIRCLES(l2)) -> List.length l1 = List.length l2
- | (Ast0.STARS(l1),Ast0.STARS(l2)) -> List.length l1 = List.length l2
- | _ -> false
-
-let rec equal_ident i1 i2 =
- match (Ast0.unwrap i1,Ast0.unwrap i2) with
- (Ast0.Id(name1),Ast0.Id(name2)) -> equal_mcode name1 name2
- | (Ast0.MetaId(name1,_,_),Ast0.MetaId(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.MetaFunc(name1,_,_),Ast0.MetaFunc(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.MetaLocalFunc(name1,_,_),Ast0.MetaLocalFunc(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.OptIdent(_),Ast0.OptIdent(_)) -> true
- | (Ast0.UniqueIdent(_),Ast0.UniqueIdent(_)) -> true
- | _ -> false
-
-let rec equal_expression e1 e2 =
- match (Ast0.unwrap e1,Ast0.unwrap e2) with
- (Ast0.Ident(_),Ast0.Ident(_)) -> true
- | (Ast0.Constant(const1),Ast0.Constant(const2)) -> equal_mcode const1 const2
- | (Ast0.FunCall(_,lp1,_,rp1),Ast0.FunCall(_,lp2,_,rp2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.Assignment(_,op1,_,_),Ast0.Assignment(_,op2,_,_)) ->
- equal_mcode op1 op2
- | (Ast0.CondExpr(_,why1,_,colon1,_),Ast0.CondExpr(_,why2,_,colon2,_)) ->
- equal_mcode why1 why2 && equal_mcode colon1 colon2
- | (Ast0.Postfix(_,op1),Ast0.Postfix(_,op2)) -> equal_mcode op1 op2
- | (Ast0.Infix(_,op1),Ast0.Infix(_,op2)) -> equal_mcode op1 op2
- | (Ast0.Unary(_,op1),Ast0.Unary(_,op2)) -> equal_mcode op1 op2
- | (Ast0.Binary(_,op1,_),Ast0.Binary(_,op2,_)) -> equal_mcode op1 op2
- | (Ast0.Paren(lp1,_,rp1),Ast0.Paren(lp2,_,rp2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.ArrayAccess(_,lb1,_,rb1),Ast0.ArrayAccess(_,lb2,_,rb2)) ->
- equal_mcode lb1 lb2 && equal_mcode rb1 rb2
- | (Ast0.RecordAccess(_,pt1,_),Ast0.RecordAccess(_,pt2,_)) ->
- equal_mcode pt1 pt2
- | (Ast0.RecordPtAccess(_,ar1,_),Ast0.RecordPtAccess(_,ar2,_)) ->
- equal_mcode ar1 ar2
- | (Ast0.Cast(lp1,_,rp1,_),Ast0.Cast(lp2,_,rp2,_)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.SizeOfExpr(szf1,_),Ast0.SizeOfExpr(szf2,_)) ->
- equal_mcode szf1 szf2
- | (Ast0.SizeOfType(szf1,lp1,_,rp1),Ast0.SizeOfType(szf2,lp2,_,rp2)) ->
- equal_mcode szf1 szf2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.TypeExp(_),Ast0.TypeExp(_)) -> true
- | (Ast0.MetaErr(name1,_,_),Ast0.MetaErr(name2,_,_))
- | (Ast0.MetaExpr(name1,_,_,_,_),Ast0.MetaExpr(name2,_,_,_,_))
- | (Ast0.MetaExprList(name1,_,_),Ast0.MetaExprList(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.EComma(cm1),Ast0.EComma(cm2)) -> equal_mcode cm1 cm2
- | (Ast0.DisjExpr(starter1,_,mids1,ender1),
- Ast0.DisjExpr(starter2,_,mids2,ender2)) ->
- equal_mcode starter1 starter2 &&
- List.for_all2 equal_mcode mids1 mids2 &&
- equal_mcode ender1 ender2
- | (Ast0.NestExpr(starter1,_,ender1,_,m1),
- Ast0.NestExpr(starter2,_,ender2,_,m2)) ->
- equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
- | (Ast0.Edots(dots1,_),Ast0.Edots(dots2,_))
- | (Ast0.Ecircles(dots1,_),Ast0.Ecircles(dots2,_))
- | (Ast0.Estars(dots1,_),Ast0.Estars(dots2,_)) -> equal_mcode dots1 dots2
- | (Ast0.OptExp(_),Ast0.OptExp(_)) -> true
- | (Ast0.UniqueExp(_),Ast0.UniqueExp(_)) -> true
- | _ -> false
-
-let rec equal_typeC t1 t2 =
- match (Ast0.unwrap t1,Ast0.unwrap t2) with
- (Ast0.ConstVol(cv1,_),Ast0.ConstVol(cv2,_)) -> equal_mcode cv1 cv2
- | (Ast0.BaseType(ty1,stringsa),Ast0.BaseType(ty2,stringsb)) ->
- List.for_all2 equal_mcode stringsa stringsb
- | (Ast0.Signed(sign1,_),Ast0.Signed(sign2,_)) ->
- equal_mcode sign1 sign2
- | (Ast0.Pointer(_,star1),Ast0.Pointer(_,star2)) ->
- equal_mcode star1 star2
- | (Ast0.Array(_,lb1,_,rb1),Ast0.Array(_,lb2,_,rb2)) ->
- equal_mcode lb1 lb2 && equal_mcode rb1 rb2
- | (Ast0.EnumName(kind1,_),Ast0.EnumName(kind2,_)) ->
- equal_mcode kind1 kind2
- | (Ast0.StructUnionName(kind1,_),Ast0.StructUnionName(kind2,_)) ->
- equal_mcode kind1 kind2
- | (Ast0.FunctionType(ty1,lp1,p1,rp1),Ast0.FunctionType(ty2,lp2,p2,rp2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.StructUnionDef(_,lb1,_,rb1),
- Ast0.StructUnionDef(_,lb2,_,rb2)) ->
- equal_mcode lb1 lb2 && equal_mcode rb1 rb2
- | (Ast0.TypeName(name1),Ast0.TypeName(name2)) -> equal_mcode name1 name2
- | (Ast0.MetaType(name1,_),Ast0.MetaType(name2,_)) ->
- equal_mcode name1 name2
- | (Ast0.DisjType(starter1,_,mids1,ender1),
- Ast0.DisjType(starter2,_,mids2,ender2)) ->
- equal_mcode starter1 starter2 &&
- List.for_all2 equal_mcode mids1 mids2 &&
- equal_mcode ender1 ender2
- | (Ast0.OptType(_),Ast0.OptType(_)) -> true
- | (Ast0.UniqueType(_),Ast0.UniqueType(_)) -> true
- | _ -> false
-
-let equal_declaration d1 d2 =
- match (Ast0.unwrap d1,Ast0.unwrap d2) with
- (Ast0.Init(stg1,_,_,eq1,_,sem1),Ast0.Init(stg2,_,_,eq2,_,sem2)) ->
- equal_option stg1 stg2 && equal_mcode eq1 eq2 && equal_mcode sem1 sem2
- | (Ast0.UnInit(stg1,_,_,sem1),Ast0.UnInit(stg2,_,_,sem2)) ->
- equal_option stg1 stg2 && equal_mcode sem1 sem2
- | (Ast0.MacroDecl(nm1,lp1,_,rp1,sem1),Ast0.MacroDecl(nm2,lp2,_,rp2,sem2)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
- | (Ast0.TyDecl(_,sem1),Ast0.TyDecl(_,sem2)) -> equal_mcode sem1 sem2
- | (Ast0.Ddots(dots1,_),Ast0.Ddots(dots2,_)) -> equal_mcode dots1 dots2
- | (Ast0.OptDecl(_),Ast0.OptDecl(_)) -> true
- | (Ast0.UniqueDecl(_),Ast0.UniqueDecl(_)) -> true
- | (Ast0.DisjDecl _,_) | (_,Ast0.DisjDecl _) ->
- failwith "DisjDecl not expected here"
- | _ -> false
-
-let equal_designator d1 d2 =
- match (d1,d2) with
- (Ast0.DesignatorField(dot1,_),Ast0.DesignatorField(dot2,_)) ->
- equal_mcode dot1 dot2
- | (Ast0.DesignatorIndex(lb1,_,rb1),Ast0.DesignatorIndex(lb2,_,rb2)) ->
- (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
- | (Ast0.DesignatorRange(lb1,_,dots1,_,rb1),
- Ast0.DesignatorRange(lb2,_,dots2,_,rb2)) ->
- (equal_mcode lb1 lb2) && (equal_mcode dots1 dots2) &&
- (equal_mcode rb1 rb2)
- | _ -> false
-
-let equal_initialiser i1 i2 =
- match (Ast0.unwrap i1,Ast0.unwrap i2) with
- (Ast0.MetaInit(name1,_),Ast0.MetaInit(name2,_)) ->
- equal_mcode name1 name2
- | (Ast0.InitExpr(_),Ast0.InitExpr(_)) -> true
- | (Ast0.InitList(lb1,_,rb1),Ast0.InitList(lb2,_,rb2)) ->
- (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
- | (Ast0.InitGccExt(designators1,eq1,_),
- Ast0.InitGccExt(designators2,eq2,_)) ->
- (List.for_all2 equal_designator designators1 designators2) &&
- (equal_mcode eq1 eq2)
- | (Ast0.InitGccName(_,eq1,_),Ast0.InitGccName(_,eq2,_)) ->
- equal_mcode eq1 eq2
- | (Ast0.IComma(cm1),Ast0.IComma(cm2)) -> equal_mcode cm1 cm2
- | (Ast0.Idots(d1,_),Ast0.Idots(d2,_)) -> equal_mcode d1 d2
- | (Ast0.OptIni(_),Ast0.OptIni(_)) -> true
- | (Ast0.UniqueIni(_),Ast0.UniqueIni(_)) -> true
- | _ -> false
-
-let equal_parameterTypeDef p1 p2 =
- match (Ast0.unwrap p1,Ast0.unwrap p2) with
- (Ast0.VoidParam(_),Ast0.VoidParam(_)) -> true
- | (Ast0.Param(_,_),Ast0.Param(_,_)) -> true
- | (Ast0.MetaParam(name1,_),Ast0.MetaParam(name2,_))
- | (Ast0.MetaParamList(name1,_,_),Ast0.MetaParamList(name2,_,_)) ->
- equal_mcode name1 name2
- | (Ast0.PComma(cm1),Ast0.PComma(cm2)) -> equal_mcode cm1 cm2
- | (Ast0.Pdots(dots1),Ast0.Pdots(dots2))
- | (Ast0.Pcircles(dots1),Ast0.Pcircles(dots2)) -> equal_mcode dots1 dots2
- | (Ast0.OptParam(_),Ast0.OptParam(_)) -> true
- | (Ast0.UniqueParam(_),Ast0.UniqueParam(_)) -> true
- | _ -> false
-
-let rec equal_statement s1 s2 =
- match (Ast0.unwrap s1,Ast0.unwrap s2) with
- (Ast0.FunDecl(_,fninfo1,_,lp1,_,rp1,lbrace1,_,rbrace1),
- Ast0.FunDecl(_,fninfo2,_,lp2,_,rp2,lbrace2,_,rbrace2)) ->
- (List.length fninfo1) = (List.length fninfo2) &&
- List.for_all2 equal_fninfo fninfo1 fninfo2 &&
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 &&
- equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
- | (Ast0.Decl(_,_),Ast0.Decl(_,_)) -> true
- | (Ast0.Seq(lbrace1,_,rbrace1),Ast0.Seq(lbrace2,_,rbrace2)) ->
- equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
- | (Ast0.ExprStatement(_,sem1),Ast0.ExprStatement(_,sem2)) ->
- equal_mcode sem1 sem2
- | (Ast0.IfThen(iff1,lp1,_,rp1,_,_),Ast0.IfThen(iff2,lp2,_,rp2,_,_)) ->
- equal_mcode iff1 iff2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.IfThenElse(iff1,lp1,_,rp1,_,els1,_,_),
- Ast0.IfThenElse(iff2,lp2,_,rp2,_,els2,_,_)) ->
- equal_mcode iff1 iff2 &&
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode els1 els2
- | (Ast0.While(whl1,lp1,_,rp1,_,_),Ast0.While(whl2,lp2,_,rp2,_,_)) ->
- equal_mcode whl1 whl2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.Do(d1,_,whl1,lp1,_,rp1,sem1),Ast0.Do(d2,_,whl2,lp2,_,rp2,sem2)) ->
- equal_mcode whl1 whl2 && equal_mcode d1 d2 &&
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
- | (Ast0.For(fr1,lp1,_,sem11,_,sem21,_,rp1,_,_),
- Ast0.For(fr2,lp2,_,sem12,_,sem22,_,rp2,_,_)) ->
- equal_mcode fr1 fr2 && equal_mcode lp1 lp2 &&
- equal_mcode sem11 sem12 && equal_mcode sem21 sem22 &&
- equal_mcode rp1 rp2
- | (Ast0.Iterator(nm1,lp1,_,rp1,_,_),Ast0.Iterator(nm2,lp2,_,rp2,_,_)) ->
- equal_mcode lp1 lp2 && equal_mcode rp1 rp2
- | (Ast0.Switch(switch1,lp1,_,rp1,lb1,case1,rb1),
- Ast0.Switch(switch2,lp2,_,rp2,lb2,case2,rb2)) ->
- equal_mcode switch1 switch2 && equal_mcode lp1 lp2 &&
- equal_mcode rp1 rp2 && equal_mcode lb1 lb2 &&
- equal_mcode rb1 rb2
- | (Ast0.Break(br1,sem1),Ast0.Break(br2,sem2)) ->
- equal_mcode br1 br2 && equal_mcode sem1 sem2
- | (Ast0.Continue(cont1,sem1),Ast0.Continue(cont2,sem2)) ->
- equal_mcode cont1 cont2 && equal_mcode sem1 sem2
- | (Ast0.Label(_,dd1),Ast0.Label(_,dd2)) ->
- equal_mcode dd1 dd2
- | (Ast0.Goto(g1,_,sem1),Ast0.Goto(g2,_,sem2)) ->
- equal_mcode g1 g2 && equal_mcode sem1 sem2
- | (Ast0.Return(ret1,sem1),Ast0.Return(ret2,sem2)) ->
- equal_mcode ret1 ret2 && equal_mcode sem1 sem2
- | (Ast0.ReturnExpr(ret1,_,sem1),Ast0.ReturnExpr(ret2,_,sem2)) ->
- equal_mcode ret1 ret2 && equal_mcode sem1 sem2
- | (Ast0.MetaStmt(name1,_),Ast0.MetaStmt(name2,_))
- | (Ast0.MetaStmtList(name1,_),Ast0.MetaStmtList(name2,_)) ->
- equal_mcode name1 name2
- | (Ast0.Disj(starter1,_,mids1,ender1),Ast0.Disj(starter2,_,mids2,ender2)) ->
- equal_mcode starter1 starter2 &&
- List.for_all2 equal_mcode mids1 mids2 &&
- equal_mcode ender1 ender2
- | (Ast0.Nest(starter1,_,ender1,_,m1),Ast0.Nest(starter2,_,ender2,_,m2)) ->
- equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
- | (Ast0.Exp(_),Ast0.Exp(_)) -> true
- | (Ast0.TopExp(_),Ast0.TopExp(_)) -> true
- | (Ast0.Ty(_),Ast0.Ty(_)) -> true
- | (Ast0.TopInit(_),Ast0.TopInit(_)) -> true
- | (Ast0.Dots(d1,_),Ast0.Dots(d2,_))
- | (Ast0.Circles(d1,_),Ast0.Circles(d2,_))
- | (Ast0.Stars(d1,_),Ast0.Stars(d2,_)) -> equal_mcode d1 d2
- | (Ast0.Include(inc1,name1),Ast0.Include(inc2,name2)) ->
- equal_mcode inc1 inc2 && equal_mcode name1 name2
- | (Ast0.Define(def1,_,_,_),Ast0.Define(def2,_,_,_)) ->
- equal_mcode def1 def2
- | (Ast0.OptStm(_),Ast0.OptStm(_)) -> true
- | (Ast0.UniqueStm(_),Ast0.UniqueStm(_)) -> true
- | _ -> false
-
-and equal_fninfo x y =
- match (x,y) with
- (Ast0.FStorage(s1),Ast0.FStorage(s2)) -> equal_mcode s1 s2
- | (Ast0.FType(_),Ast0.FType(_)) -> true
- | (Ast0.FInline(i1),Ast0.FInline(i2)) -> equal_mcode i1 i2
- | (Ast0.FAttr(i1),Ast0.FAttr(i2)) -> equal_mcode i1 i2
- | _ -> false
-
-let equal_case_line c1 c2 =
- match (Ast0.unwrap c1,Ast0.unwrap c2) with
- (Ast0.Default(def1,colon1,_),Ast0.Default(def2,colon2,_)) ->
- equal_mcode def1 def2 && equal_mcode colon1 colon2
- | (Ast0.Case(case1,_,colon1,_),Ast0.Case(case2,_,colon2,_)) ->
- equal_mcode case1 case2 && equal_mcode colon1 colon2
- | (Ast0.OptCase(_),Ast0.OptCase(_)) -> true
- | _ -> false
-
-let rec equal_top_level t1 t2 =
- match (Ast0.unwrap t1,Ast0.unwrap t2) with
- (Ast0.DECL(_),Ast0.DECL(_)) -> true
- | (Ast0.FILEINFO(old_file1,new_file1),Ast0.FILEINFO(old_file2,new_file2)) ->
- equal_mcode old_file1 old_file2 && equal_mcode new_file1 new_file2
- | (Ast0.CODE(_),Ast0.CODE(_)) -> true
- | (Ast0.ERRORWORDS(_),Ast0.ERRORWORDS(_)) -> true
- | _ -> false
-
-let root_equal e1 e2 =
- match (e1,e2) with
- (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) -> dots equal_expression d1 d2
- | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
- dots equal_parameterTypeDef d1 d2
- | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) -> dots equal_statement d1 d2
- | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) -> dots equal_declaration d1 d2
- | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) -> dots equal_case_line d1 d2
- | (Ast0.IdentTag(i1),Ast0.IdentTag(i2)) -> equal_ident i1 i2
- | (Ast0.ExprTag(e1),Ast0.ExprTag(e2)) -> equal_expression e1 e2
- | (Ast0.ArgExprTag(d),_) -> failwith "not possible - iso only"
- | (Ast0.TypeCTag(t1),Ast0.TypeCTag(t2)) -> equal_typeC t1 t2
- | (Ast0.ParamTag(p1),Ast0.ParamTag(p2)) -> equal_parameterTypeDef p1 p2
- | (Ast0.InitTag(d1),Ast0.InitTag(d2)) -> equal_initialiser d1 d2
- | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) -> equal_declaration d1 d2
- | (Ast0.StmtTag(s1),Ast0.StmtTag(s2)) -> equal_statement s1 s2
- | (Ast0.TopTag(t1),Ast0.TopTag(t2)) -> equal_top_level t1 t2
- | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_))
- | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_))
- | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
- failwith "only within iso phase"
- | _ -> false
-
-let default_context _ =
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info))
-
-let traverse minus_table plus_table =
- Hashtbl.iter
- (function key ->
- function (e,l) ->
- try
- let (plus_e,plus_l) = Hashtbl.find plus_table key in
- if root_equal e plus_e &&
- List.for_all (function x -> x)
- (List.map2 Common.equal_set l plus_l)
- then
- let i = Ast0.fresh_index() in
- (set_index e i; set_index plus_e i;
- set_mcodekind e (default_context());
- set_mcodekind plus_e (default_context()))
- with Not_found -> ())
- minus_table
-
-(* --------------------------------------------------------------------- *)
-(* contextify the whencode *)
-
-let contextify_all =
- let bind x y = () in
- let option_default = () in
- let mcode x = () in
- let do_nothing r k e = Ast0.set_mcodekind e (default_context()); k e in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing do_nothing do_nothing
-
-let contextify_whencode =
- let bind x y = () in
- let option_default = () in
- let mcode x = () in
- let do_nothing r k e = k e in
-
- let expression r k e =
- k e;
- match Ast0.unwrap e with
- Ast0.NestExpr(_,_,_,Some whencode,_)
- | Ast0.Edots(_,Some whencode)
- | Ast0.Ecircles(_,Some whencode)
- | Ast0.Estars(_,Some whencode) ->
- contextify_all.V0.combiner_expression whencode
- | _ -> () in
-
- let initialiser r k i =
- match Ast0.unwrap i with
- Ast0.Idots(dots,Some whencode) ->
- contextify_all.V0.combiner_initialiser whencode
- | _ -> k i in
-
- let whencode = function
- Ast0.WhenNot sd -> contextify_all.V0.combiner_statement_dots sd
- | Ast0.WhenAlways s -> contextify_all.V0.combiner_statement s
- | Ast0.WhenModifier(_) -> ()
- | Ast0.WhenNotTrue(e) -> contextify_all.V0.combiner_expression e
- | Ast0.WhenNotFalse(e) -> contextify_all.V0.combiner_expression e in
-
- let statement r k (s : Ast0.statement) =
- k s;
- match Ast0.unwrap s with
- Ast0.Nest(_,_,_,whn,_)
- | Ast0.Dots(_,whn) | Ast0.Circles(_,whn) | Ast0.Stars(_,whn) ->
- List.iter whencode whn
- | _ -> () in
-
- let combiner =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
- do_nothing
- expression
- do_nothing initialiser do_nothing do_nothing statement do_nothing
- do_nothing in
- combiner.V0.combiner_top_level
-
-(* --------------------------------------------------------------------- *)
-
-(* the first int list is the tokens in the node, the second is the tokens
-in the descendents *)
-let minus_table =
- (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
-let plus_table =
- (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
-
-let iscode t =
- match Ast0.unwrap t with
- Ast0.DECL(_) -> true
- | Ast0.FILEINFO(_) -> true
- | Ast0.ERRORWORDS(_) -> false
- | Ast0.CODE(_) -> true
- | Ast0.OTHER(_) -> failwith "unexpected top level code"
-
-(* ------------------------------------------------------------------- *)
-(* alignment of minus and plus *)
-
-let concat = function
- [] -> []
- | [s] -> [s]
- | l ->
- let rec loop = function
- [] -> []
- | x::rest ->
- (match Ast0.unwrap x with
- Ast0.DECL(s) -> let stms = loop rest in s::stms
- | Ast0.CODE(ss) ->
- let stms = loop rest in
- (match Ast0.unwrap ss with
- Ast0.DOTS(d) -> d@stms
- | _ -> failwith "no dots allowed in pure plus code")
- | _ -> failwith "plus code is being discarded") in
- let res =
- Compute_lines.statement_dots
- (Ast0.rewrap (List.hd l) (Ast0.DOTS (loop l))) in
- [Ast0.rewrap res (Ast0.CODE res)]
-
-let collect_up_to m plus =
- let minfo = Ast0.get_info m in
- let mend = minfo.Ast0.logical_end in
- let rec loop = function
- [] -> ([],[])
- | p::plus ->
- let pinfo = Ast0.get_info p in
- let pstart = pinfo.Ast0.logical_start in
- if pstart > mend
- then ([],p::plus)
- else let (plus,rest) = loop plus in (p::plus,rest) in
- let (plus,rest) = loop plus in
- (concat plus,rest)
-
-let realign minus plus =
- let rec loop = function
- ([],_) -> failwith "not possible, some context required"
- | ([m],p) -> ([m],concat p)
- | (m::minus,plus) ->
- let (p,plus) = collect_up_to m plus in
- let (minus,plus) = loop (minus,plus) in
- (m::minus,p@plus) in
- loop (minus,plus)
-
-(* ------------------------------------------------------------------- *)
-(* check compatible: check that at the top level the minus and plus code is
-of the same kind. Could go further and make the correspondence between the
-code between ...s. *)
-
-let isonly f l = match Ast0.undots l with [s] -> f s | _ -> false
-
-let isall f l = List.for_all (isonly f) l
-
-let rec is_exp s =
- match Ast0.unwrap s with
- Ast0.Exp(e) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_exp stmts
- | _ -> false
-
-let rec is_ty s =
- match Ast0.unwrap s with
- Ast0.Ty(e) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_ty stmts
- | _ -> false
-
-let rec is_init s =
- match Ast0.unwrap s with
- Ast0.TopInit(e) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_init stmts
- | _ -> false
-
-let rec is_decl s =
- match Ast0.unwrap s with
- Ast0.Decl(_,e) -> true
- | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_decl stmts
- | _ -> false
-
-let rec is_fndecl s =
- match Ast0.unwrap s with
- Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_fndecl stmts
- | _ -> false
-
-let rec is_toplevel s =
- match Ast0.unwrap s with
- Ast0.Decl(_,e) -> true
- | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
- | Ast0.Disj(_,stmts,_,_) -> isall is_toplevel stmts
- | Ast0.ExprStatement(fc,_) ->
- (match Ast0.unwrap fc with
- Ast0.FunCall(_,_,_,_) -> true
- | _ -> false)
- | Ast0.Include(_,_) -> true
- | Ast0.Define(_,_,_,_) -> true
- | _ -> false
-
-let check_compatible m p =
- let fail _ =
- failwith
- (Printf.sprintf
- "incompatible minus and plus code starting on lines %d and %d"
- (Ast0.get_line m) (Ast0.get_line p)) in
- match (Ast0.unwrap m, Ast0.unwrap p) with
- (Ast0.DECL(decl1),Ast0.DECL(decl2)) ->
- if not (is_decl decl1 && is_decl decl2)
- then fail()
- | (Ast0.DECL(decl1),Ast0.CODE(code2)) ->
- let v1 = is_decl decl1 in
- let v2 = List.for_all is_toplevel (Ast0.undots code2) in
- if !Flag.make_hrule = None && v1 && not v2 then fail()
- | (Ast0.CODE(code1),Ast0.DECL(decl2)) ->
- let v1 = List.for_all is_toplevel (Ast0.undots code1) in
- let v2 = is_decl decl2 in
- if v1 && not v2 then fail()
- | (Ast0.CODE(code1),Ast0.CODE(code2)) ->
- let v1 = isonly is_init code1 in
- let v2a = isonly is_init code2 in
- let v2b = isonly is_exp code2 in
- if v1
- then (if not (v2a || v2b) then fail())
- else
- let testers = [is_exp;is_ty] in
- List.iter
- (function tester ->
- let v1 = isonly tester code1 in
- let v2 = isonly tester code2 in
- if (v1 && not v2) or (!Flag.make_hrule = None && v2 && not v1)
- then fail())
- testers;
- let v1 = isonly is_fndecl code1 in
- let v2 = List.for_all is_toplevel (Ast0.undots code2) in
- if !Flag.make_hrule = None && v1 && not v2 then fail()
- | (Ast0.FILEINFO(_,_),Ast0.FILEINFO(_,_)) -> ()
- | (Ast0.OTHER(_),Ast0.OTHER(_)) -> ()
- | _ -> fail()
-
-(* ------------------------------------------------------------------- *)
-
-(* returns a list of corresponding minus and plus trees *)
-let context_neg minus plus =
- Hashtbl.clear minus_table;
- Hashtbl.clear plus_table;
- List.iter contextify_whencode minus;
- let (minus,plus) = realign minus plus in
- let rec loop = function
- ([],[]) -> []
- | ([],l) ->
- failwith (Printf.sprintf "%d plus things remaining" (List.length l))
- | (minus,[]) ->
- plus_lines := [];
- let _ =
- List.map
- (function m ->
- classify true
- (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
- minus_table m)
- minus in
- []
- | (((m::minus) as mall),((p::plus) as pall)) ->
- let minfo = Ast0.get_info m in
- let pinfo = Ast0.get_info p in
- let mstart = minfo.Ast0.logical_start in
- let mend = minfo.Ast0.logical_end in
- let pstart = pinfo.Ast0.logical_start in
- let pend = pinfo.Ast0.logical_end in
- if (iscode m or iscode p) &&
- (mend + 1 = pstart or pend + 1 = mstart or (* adjacent *)
- (mstart <= pstart && mend >= pstart) or
- (pstart <= mstart && pend >= mstart)) (* overlapping or nested *)
- then
- begin
- (* ensure that the root of each tree has a unique index,
- although it might get overwritten if the node is a context
- node *)
- let i = Ast0.fresh_index() in
- Ast0.set_index m i; Ast0.set_index p i;
- check_compatible m p;
- collect_plus_lines p;
- let _ =
- classify true
- (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
- minus_table m in
- let _ = classify false (function _ -> Ast0.PLUS) plus_table p in
- traverse minus_table plus_table;
- (m,p)::loop(minus,plus)
- end
- else
- if not(iscode m or iscode p)
- then loop(minus,plus)
- else
- if mstart < pstart
- then
- begin
- plus_lines := [];
- let _ =
- classify true
- (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
- minus_table m in
- loop(minus,pall)
- end
- else loop(mall,plus) in
- loop(minus,plus)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* types that clutter the .mly file *)
-(* for iso metavariables, true if they can only match nonmodified, unitary
- metavariables *)
-type fresh = bool
-
-type clt =
- line_type * int * int * int * int (* starting spaces *) *
- string list (* code before *) * string list (* code after *) *
- Ast0.meta_pos (* position variable, minus only *)
-
-(* ---------------------------------------------------------------------- *)
-
-(* Things that need to be seen by the lexer and parser. *)
-
-and line_type =
- MINUS | OPTMINUS | UNIQUEMINUS
- | PLUS
- | CONTEXT | UNIQUE | OPT
-
-type iconstraints = Ast0.ident list
-type econstraints = Ast0.expression list
-type pconstraints = Ast.meta_name list
-
-let in_rule_name = ref false
-let in_meta = ref false
-let in_iso = ref false
-let in_generating = ref false
-let in_prolog = ref false
-let inheritable_positions =
- ref ([] : string list) (* rules from which posns can be inherited *)
-
-let all_metadecls =
- (Hashtbl.create(100) : (string, Ast.metavar list) Hashtbl.t)
-
-let clear_meta: (unit -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_id_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_type_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_param_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_paramlist_meta:
- (Ast.meta_name -> Ast.meta_name option -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_const_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_err_meta:
- (Ast.meta_name -> econstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_exp_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_idexp_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_local_idexp_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_explist_meta:
- (Ast.meta_name -> Ast.meta_name option -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_stm_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_stmlist_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_func_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_local_func_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_declarer_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_decl")
-
-let add_iterator_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_iter")
-
-let add_pos_meta:
- (Ast.meta_name -> pconstraints -> Ast.meta_collect -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_type_name: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_type")
-
-let add_declarer_name: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_decl")
-
-let add_iterator_name: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_iter")
-
-let init_rule: (unit -> unit) ref =
- ref (fun _ -> failwith "uninitialized install_bindings")
-
-let install_bindings: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized install_bindings")
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* types that clutter the .mly file *)
-(* for iso metavariables, true if they can only match nonmodified, unitary
- metavariables *)
-type fresh = bool
-
-type clt =
- line_type * int * int * int * int (* starting spaces *) *
- string list (* code before *) * string list (* code after *) *
- Ast0.meta_pos (* position variable, minus only *)
-
-(* ---------------------------------------------------------------------- *)
-
-(* Things that need to be seen by the lexer and parser. *)
-
-and line_type =
- MINUS | OPTMINUS | UNIQUEMINUS
- | PLUS
- | CONTEXT | UNIQUE | OPT
-
-type iconstraints = Ast0.ident list
-type econstraints = Ast0.expression list
-type pconstraints = Ast.meta_name list
-
-let in_rule_name = ref false
-let in_meta = ref false
-let in_iso = ref false
-let in_generating = ref false
-let in_prolog = ref false
-let inheritable_positions =
- ref ([] : string list) (* rules from which posns can be inherited *)
-
-let all_metadecls =
- (Hashtbl.create(100) : (string, Ast.metavar list) Hashtbl.t)
-
-let clear_meta: (unit -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_id_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_type_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_init_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_param_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_paramlist_meta:
- (Ast.meta_name -> Ast.meta_name option -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_const_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_err_meta:
- (Ast.meta_name -> econstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_exp_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_idexp_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_local_idexp_meta:
- (Type_cocci.typeC list option -> Ast.meta_name -> econstraints ->
- Ast0.pure -> unit)
- ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_explist_meta:
- (Ast.meta_name -> Ast.meta_name option -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_stm_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_stmlist_meta: (Ast.meta_name -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_func_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_local_func_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_declarer_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_decl")
-
-let add_iterator_meta:
- (Ast.meta_name -> iconstraints -> Ast0.pure -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_iter")
-
-let add_pos_meta:
- (Ast.meta_name -> pconstraints -> Ast.meta_collect -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_meta")
-
-let add_type_name: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_type")
-
-let add_declarer_name: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_decl")
-
-let add_iterator_name: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized add_iter")
-
-let init_rule: (unit -> unit) ref =
- ref (fun _ -> failwith "uninitialized install_bindings")
-
-let install_bindings: (string -> unit) ref =
- ref (fun _ -> failwith "uninitialized install_bindings")
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast = Ast_cocci
-module V = Visitor_ast
-
-let disjmult2 e1 e2 k =
- List.concat
- (List.map (function e1 -> List.map (function e2 -> k e1 e2) e2) e1)
-
-let disjmult3 e1 e2 e3 k =
- List.concat
- (List.map
- (function e1 ->
- List.concat
- (List.map
- (function e2 -> List.map (function e3 -> k e1 e2 e3) e3)
- e2))
- e1)
-
-let rec disjmult f = function
- [] -> [[]]
- | x::xs ->
- let cur = f x in
- let rest = disjmult f xs in
- disjmult2 cur rest (function cur -> function rest -> cur :: rest)
-
-let disjoption f = function
- None -> [None]
- | Some x -> List.map (function x -> Some x) (f x)
-
-let disjdots f d =
- match Ast.unwrap d with
- Ast.DOTS(l) ->
- List.map (function l -> Ast.rewrap d (Ast.DOTS(l))) (disjmult f l)
- | Ast.CIRCLES(l) ->
- List.map (function l -> Ast.rewrap d (Ast.CIRCLES(l))) (disjmult f l)
- | Ast.STARS(l) ->
- List.map (function l -> Ast.rewrap d (Ast.STARS(l))) (disjmult f l)
-
-let rec disjty ft =
- match Ast.unwrap ft with
- Ast.Type(cv,ty) ->
- let ty = disjtypeC ty in
- List.map (function ty -> Ast.rewrap ft (Ast.Type(cv,ty))) ty
- | Ast.DisjType(types) -> List.concat (List.map disjty types)
- | Ast.OptType(ty) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap ft (Ast.OptType(ty))) ty
- | Ast.UniqueType(ty) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap ft (Ast.UniqueType(ty))) ty
-
-and disjtypeC bty =
- match Ast.unwrap bty with
- Ast.BaseType(_) | Ast.SignedT(_,_) -> [bty]
- | Ast.Pointer(ty,star) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap bty (Ast.Pointer(ty,star))) ty
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- let ty = disjty ty in
- List.map
- (function ty ->
- Ast.rewrap bty (Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2)))
- ty
- | Ast.FunctionType (s,ty,lp1,params,rp1) ->
- let ty = disjoption disjty ty in
- List.map
- (function ty ->
- Ast.rewrap bty (Ast.FunctionType (s,ty,lp1,params,rp1)))
- ty
- | Ast.Array(ty,lb,size,rb) ->
- disjmult2 (disjty ty) (disjoption disjexp size)
- (function ty -> function size ->
- Ast.rewrap bty (Ast.Array(ty,lb,size,rb)))
- | Ast.EnumName(_,_) | Ast.StructUnionName(_,_) -> [bty]
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- disjmult2 (disjty ty) (disjdots disjdecl decls)
- (function ty -> function decls ->
- Ast.rewrap bty (Ast.StructUnionDef(ty,lb,decls,rb)))
- | Ast.TypeName(_) | Ast.MetaType(_,_,_) -> [bty]
-
-and disjexp e =
- match Ast.unwrap e with
- Ast.Ident(_) | Ast.Constant(_) -> [e]
- | Ast.FunCall(fn,lp,args,rp) ->
- disjmult2 (disjexp fn) (disjdots disjexp args)
- (function fn -> function args ->
- Ast.rewrap e (Ast.FunCall(fn,lp,args,rp)))
- | Ast.Assignment(left,op,right,simple) ->
- disjmult2 (disjexp left) (disjexp right)
- (function left -> function right ->
- Ast.rewrap e (Ast.Assignment(left,op,right,simple)))
- | Ast.CondExpr(exp1,why,Some exp2,colon,exp3) ->
- let res = disjmult disjexp [exp1;exp2;exp3] in
- List.map
- (function
- [exp1;exp2;exp3] ->
- Ast.rewrap e (Ast.CondExpr(exp1,why,Some exp2,colon,exp3))
- | _ -> failwith "not possible")
- res
- | Ast.CondExpr(exp1,why,None,colon,exp3) ->
- disjmult2 (disjexp exp1) (disjexp exp3)
- (function exp1 -> function exp3 ->
- Ast.rewrap e (Ast.CondExpr(exp1,why,None,colon,exp3)))
- | Ast.Postfix(exp,op) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.Postfix(exp,op))) exp
- | Ast.Infix(exp,op) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.Infix(exp,op))) exp
- | Ast.Unary(exp,op) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.Unary(exp,op))) exp
- | Ast.Binary(left,op,right) ->
- disjmult2 (disjexp left) (disjexp right)
- (function left -> function right ->
- Ast.rewrap e (Ast.Binary(left,op,right)))
- | Ast.Nested(exp,op,right) ->
- (* disj not possible in right *)
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.Nested(exp,op,right))) exp
- | Ast.Paren(lp,exp,rp) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.Paren(lp,exp,rp))) exp
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- disjmult2 (disjexp exp1) (disjexp exp2)
- (function exp1 -> function exp2 ->
- Ast.rewrap e (Ast.ArrayAccess(exp1,lb,exp2,rb)))
- | Ast.RecordAccess(exp,pt,field) ->
- let exp = disjexp exp in
- List.map
- (function exp -> Ast.rewrap e (Ast.RecordAccess(exp,pt,field))) exp
- | Ast.RecordPtAccess(exp,ar,field) ->
- let exp = disjexp exp in
- List.map
- (function exp -> Ast.rewrap e (Ast.RecordPtAccess(exp,ar,field))) exp
- | Ast.Cast(lp,ty,rp,exp) ->
- disjmult2 (disjty ty) (disjexp exp)
- (function ty -> function exp -> Ast.rewrap e (Ast.Cast(lp,ty,rp,exp)))
- | Ast.SizeOfExpr(szf,exp) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.SizeOfExpr(szf,exp))) exp
- | Ast.SizeOfType(szf,lp,ty,rp) ->
- let ty = disjty ty in
- List.map
- (function ty -> Ast.rewrap e (Ast.SizeOfType(szf,lp,ty,rp))) ty
- | Ast.TypeExp(ty) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap e (Ast.TypeExp(ty))) ty
- | Ast.MetaErr(_,_,_,_) | Ast.MetaExpr(_,_,_,_,_,_)
- | Ast.MetaExprList(_,_,_,_) | Ast.EComma(_) -> [e]
- | Ast.DisjExpr(exp_list) ->
- List.concat (List.map disjexp exp_list)
- | Ast.NestExpr(expr_dots,whencode,multi) ->
- (* not sure what to do here, so ambiguities still possible *)
- [e]
- | Ast.Edots(dots,_) | Ast.Ecircles(dots,_) | Ast.Estars(dots,_) -> [e]
- | Ast.OptExp(exp) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.OptExp(exp))) exp
- | Ast.UniqueExp(exp) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap e (Ast.UniqueExp(exp))) exp
-
-and disjparam p =
- match Ast.unwrap p with
- Ast.VoidParam(ty) -> [p] (* void is the only possible value *)
- | Ast.Param(ty,id) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap p (Ast.Param(ty,id))) ty
- | Ast.MetaParam(_,_,_) | Ast.MetaParamList(_,_,_,_) | Ast.PComma(_) -> [p]
- | Ast.Pdots(dots) | Ast.Pcircles(dots) -> [p]
- | Ast.OptParam(param) ->
- let param = disjparam param in
- List.map (function param -> Ast.rewrap p (Ast.OptParam(param))) param
- | Ast.UniqueParam(param) ->
- let param = disjparam param in
- List.map (function param -> Ast.rewrap p (Ast.UniqueParam(param))) param
-
-and disjini i =
- match Ast.unwrap i with
- Ast.InitExpr(exp) ->
- let exp = disjexp exp in
- List.map (function exp -> Ast.rewrap i (Ast.InitExpr(exp))) exp
- | Ast.InitList(lb,initlist,rb,whencode) ->
- List.map
- (function initlist ->
- Ast.rewrap i (Ast.InitList(lb,initlist,rb,whencode)))
- (disjmult disjini initlist)
- | Ast.InitGccDotName(dot,name,eq,ini) ->
- let ini = disjini ini in
- List.map
- (function ini -> Ast.rewrap i (Ast.InitGccDotName(dot,name,eq,ini)))
- ini
- | Ast.InitGccName(name,eq,ini) ->
- let ini = disjini ini in
- List.map
- (function ini -> Ast.rewrap i (Ast.InitGccName(name,eq,ini)))
- ini
- | Ast.InitGccIndex(lb,exp,rb,eq,ini) ->
- disjmult2 (disjexp exp) (disjini ini)
- (function exp -> function ini ->
- Ast.rewrap i (Ast.InitGccIndex(lb,exp,rb,eq,ini)))
- | Ast.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- disjmult3 (disjexp exp1) (disjexp exp2) (disjini ini)
- (function exp1 -> function exp2 -> function ini ->
- Ast.rewrap i (Ast.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini)))
- | Ast.IComma(comma) -> [i]
- | Ast.OptIni(ini) ->
- let ini = disjini ini in
- List.map (function ini -> Ast.rewrap i (Ast.OptIni(ini))) ini
- | Ast.UniqueIni(ini) ->
- let ini = disjini ini in
- List.map (function ini -> Ast.rewrap i (Ast.UniqueIni(ini))) ini
-
-and disjdecl d =
- match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- disjmult2 (disjty ty) (disjini ini)
- (function ty -> function ini ->
- Ast.rewrap d (Ast.Init(stg,ty,id,eq,ini,sem)))
- | Ast.UnInit(stg,ty,id,sem) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap d (Ast.UnInit(stg,ty,id,sem))) ty
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- List.map
- (function args -> Ast.rewrap d (Ast.MacroDecl(name,lp,args,rp,sem)))
- (disjdots disjexp args)
- | Ast.TyDecl(ty,sem) ->
- let ty = disjty ty in
- List.map (function ty -> Ast.rewrap d (Ast.TyDecl(ty,sem))) ty
- | Ast.Typedef(stg,ty,id,sem) ->
- let ty = disjty ty in (* disj not allowed in id *)
- List.map (function ty -> Ast.rewrap d (Ast.Typedef(stg,ty,id,sem))) ty
- | Ast.DisjDecl(decls) -> List.concat (List.map disjdecl decls)
- | Ast.Ddots(_,_) | Ast.MetaDecl(_,_,_) -> [d]
- | Ast.OptDecl(decl) ->
- let decl = disjdecl decl in
- List.map (function decl -> Ast.rewrap d (Ast.OptDecl(decl))) decl
- | Ast.UniqueDecl(decl) ->
- let decl = disjdecl decl in
- List.map (function decl -> Ast.rewrap d (Ast.UniqueDecl(decl))) decl
-
-let generic_orify_rule_elem f re exp rebuild =
- match f exp with
- [exp] -> re
- | orexps -> Ast.rewrap re (Ast.DisjRuleElem (List.map rebuild orexps))
-
-let orify_rule_elem re exp rebuild =
- generic_orify_rule_elem disjexp re exp rebuild
-
-let orify_rule_elem_ty = generic_orify_rule_elem disjty
-let orify_rule_elem_param = generic_orify_rule_elem disjparam
-let orify_rule_elem_decl = generic_orify_rule_elem disjdecl
-let orify_rule_elem_ini = generic_orify_rule_elem disjini
-
-let disj_rule_elem r k re =
- match Ast.unwrap re with
- Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp) ->
- generic_orify_rule_elem (disjdots disjparam) re params
- (function params ->
- Ast.rewrap re
- (Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp)))
- | Ast.Decl(bef,allminus,decl) ->
- orify_rule_elem_decl re decl
- (function decl -> Ast.rewrap re (Ast.Decl(bef,allminus,decl)))
- | Ast.SeqStart(brace) -> re
- | Ast.SeqEnd(brace) -> re
- | Ast.ExprStatement(exp,sem) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.ExprStatement(exp,sem)))
- | Ast.IfHeader(iff,lp,exp,rp) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.IfHeader(iff,lp,exp,rp)))
- | Ast.Else(els) -> re
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.WhileHeader(whl,lp,exp,rp)))
- | Ast.DoHeader(d) -> re
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.WhileTail(whl,lp,exp,rp,sem)))
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- generic_orify_rule_elem (disjmult (disjoption disjexp)) re [e1;e2;e3]
- (function
- [exp1;exp2;exp3] ->
- Ast.rewrap re (Ast.ForHeader(fr,lp,exp1,sem1,exp2,sem2,exp3,rp))
- | _ -> failwith "not possible")
- | Ast.IteratorHeader(whl,lp,args,rp) ->
- generic_orify_rule_elem (disjdots disjexp) re args
- (function args -> Ast.rewrap re (Ast.IteratorHeader(whl,lp,args,rp)))
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.SwitchHeader(switch,lp,exp,rp)))
- | Ast.Break(_,_) | Ast.Continue(_,_) | Ast.Label(_,_) | Ast.Goto(_,_,_)
- | Ast.Return(_,_) -> re
- | Ast.ReturnExpr(ret,exp,sem) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.ReturnExpr(ret,exp,sem)))
- | Ast.MetaRuleElem(_,_,_) | Ast.MetaStmt(_,_,_,_)
- | Ast.MetaStmtList(_,_,_) -> re
- | Ast.Exp(exp) ->
- orify_rule_elem re exp (function exp -> Ast.rewrap exp (Ast.Exp(exp)))
- | Ast.TopExp(exp) ->
- orify_rule_elem re exp (function exp -> Ast.rewrap exp (Ast.TopExp(exp)))
- | Ast.Ty(ty) ->
- orify_rule_elem_ty re ty (function ty -> Ast.rewrap ty (Ast.Ty(ty)))
- | Ast.TopInit(init) ->
- orify_rule_elem_ini re init
- (function init -> Ast.rewrap init (Ast.TopInit(init)))
- | Ast.Include(inc,s) -> re
- | Ast.DefineHeader(def,id,params) -> re
- | Ast.Default(def,colon) -> re
- | Ast.Case(case,exp,colon) ->
- orify_rule_elem re exp
- (function exp -> Ast.rewrap re (Ast.Case(case,exp,colon)))
- | Ast.DisjRuleElem(_) -> failwith "not possible"
-
-let disj_all =
- let mcode x = x in
- let donothing r k e = k e in
- V.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- disj_rule_elem donothing donothing donothing donothing
-
-(* ----------------------------------------------------------------------- *)
-(* collect iso information at the rule_elem level *)
-
-let collect_all_isos =
- let bind = (@) in
- let option_default = [] in
- let mcode r x = [] in
- let donothing r k e = Common.union_set (Ast.get_isos e) (k e) in
- let doanything r k e = k e in
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing doanything
-
-let collect_iso_info =
- let mcode x = x in
- let donothing r k e = k e in
- let rule_elem r k e =
- match Ast.unwrap e with
- Ast.DisjRuleElem(l) -> k e
- | _ ->
- let isos = collect_all_isos.V.combiner_rule_elem e in
- Ast.set_isos e isos in
- V.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing rule_elem donothing donothing
- donothing donothing
-
-(* ----------------------------------------------------------------------- *)
-
-let disj rules =
- List.map
- (function (mv,r) ->
- match r with
- Ast.ScriptRule _ -> (mv, r)
- | Ast.CocciRule (nm, rule_info, r, isexp, ruletype) ->
- let res =
- List.map
- (function x ->
- let res = disj_all.V.rebuilder_top_level x in
- if !Flag.track_iso_usage
- then collect_iso_info.V.rebuilder_top_level res
- else res)
- r in
- (mv, Ast.CocciRule (nm,rule_info,res,isexp,ruletype)))
- rules
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* For each rule return the list of variables that are used after it.
-Also augment various parts of each rule with unitary, inherited, and freshness
-informations *)
-
-module Ast = Ast_cocci
-module V = Visitor_ast
-module TC = Type_cocci
-
-let rec nub = function
- [] -> []
- | (x::xs) when (List.mem x xs) -> nub xs
- | (x::xs) -> x::(nub xs)
-
-(* Collect all variable references in a minirule. For a disj, we collect
-the maximum number (2 is enough) of references in any branch. *)
-
-let collect_unitary_nonunitary free_usage =
- let free_usage = List.sort compare free_usage in
- let rec loop1 todrop = function (* skips multiple occurrences *)
- [] -> []
- | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
- let rec loop2 = function
- [] -> ([],[])
- | [x] -> ([x],[])
- | x::y::xs ->
- if x = y (* occurs more than once in free_usage *)
- then
- let (unitary,non_unitary) = loop2(loop1 x xs) in
- (unitary,x::non_unitary)
- else (* occurs only once in free_usage *)
- let (unitary,non_unitary) = loop2 (y::xs) in
- (x::unitary,non_unitary) in
- loop2 free_usage
-
-let collect_refs include_constraints =
- let bind x y = x @ y in
- let option_default = [] in
-
- let donothing recursor k e = k e in (* just combine in the normal way *)
-
- let donothing_a recursor k e = (* anything is not wrapped *)
- k e in (* just combine in the normal way *)
-
- (* the following considers that anything that occurs non-unitarily in one
- branch occurs nonunitarily in all branches. This is not optimal, but
- doing better seems to require a breadth-first traversal, which is
- perhaps better to avoid. Also, unitarily is represented as occuring once,
- while nonunitarily is represented as twice - more is irrelevant *)
- (* cases for disjs and metavars *)
- let bind_disj refs_branches =
- let (unitary,nonunitary) =
- List.split (List.map collect_unitary_nonunitary refs_branches) in
- let unitary = nub (List.concat unitary) in
- let nonunitary = nub (List.concat nonunitary) in
- let unitary =
- List.filter (function x -> not (List.mem x nonunitary)) unitary in
- unitary@nonunitary@nonunitary in
-
- let metaid (x,_,_,_) = x in
-
- let astfvident recursor k i =
- bind (k i)
- (match Ast.unwrap i with
- Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
- | Ast.MetaLocalFunc(name,_,_,_) -> [metaid name]
- | _ -> option_default) in
-
- let rec type_collect res = function
- TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
- | TC.Array(ty) -> type_collect res ty
- | TC.MetaType(tyname,_,_) -> bind [tyname] res
- | TC.SignedT(_,Some ty) -> type_collect res ty
- | ty -> res in
-
- let astfvexpr recursor k e =
- bind (k e)
- (match Ast.unwrap e with
- Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
- let types = List.fold_left type_collect option_default type_list in
- bind [metaid name] types
- | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) -> [metaid name]
- | Ast.MetaExprList(name,None,_,_) -> [metaid name]
- | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
- [metaid name;metaid lenname]
- | Ast.DisjExpr(exps) -> bind_disj (List.map k exps)
- | _ -> option_default) in
-
- let astfvdecls recursor k d =
- bind (k d)
- (match Ast.unwrap d with
- Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
- | _ -> option_default) in
-
- let astfvfullType recursor k ty =
- bind (k ty)
- (match Ast.unwrap ty with
- Ast.DisjType(types) -> bind_disj (List.map k types)
- | _ -> option_default) in
-
- let astfvtypeC recursor k ty =
- bind (k ty)
- (match Ast.unwrap ty with
- Ast.MetaType(name,_,_) -> [metaid name]
- | _ -> option_default) in
-
- let astfvparam recursor k p =
- bind (k p)
- (match Ast.unwrap p with
- Ast.MetaParam(name,_,_) -> [metaid name]
- | Ast.MetaParamList(name,None,_,_) -> [metaid name]
- | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
- [metaid name;metaid lenname]
- | _ -> option_default) in
-
- let astfvrule_elem recursor k re =
- (*within a rule_elem, pattern3 manages the coherence of the bindings*)
- bind (k re)
- (nub
- (match Ast.unwrap re with
- Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
- | Ast.MetaStmtList(name,_,_) -> [metaid name]
- | _ -> option_default)) in
-
- let astfvstatement recursor k s =
- bind (k s)
- (match Ast.unwrap s with
- Ast.Disj(stms) ->
- bind_disj (List.map recursor.V.combiner_statement_dots stms)
- | _ -> option_default) in
-
- let mcode r mc =
- if include_constraints
- then
- match Ast.get_pos_var mc with
- Ast.MetaPos(name,constraints,_,_,_) -> (metaid name)::constraints
- | _ -> option_default
- else option_default in
-
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- astfvident astfvexpr astfvfullType astfvtypeC donothing astfvparam
- astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
-
-let collect_all_refs = collect_refs true
-let collect_non_constraint_refs = collect_refs false
-
-let collect_all_rule_refs minirules =
- List.fold_left (@) []
- (List.map collect_all_refs.V.combiner_top_level minirules)
-
-let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level
-
-(* ---------------------------------------------------------------- *)
-
-let collect_saved =
- let bind = Common.union_set in
- let option_default = [] in
-
- let donothing recursor k e = k e in (* just combine in the normal way *)
-
- let metaid (x,_,_,_) = x in
-
- (* cases for metavariables *)
- let astfvident recursor k i =
- bind (k i)
- (match Ast.unwrap i with
- Ast.MetaId(name,_,TC.Saved,_) | Ast.MetaFunc(name,_,TC.Saved,_)
- | Ast.MetaLocalFunc(name,_,TC.Saved,_) -> [metaid name]
- | _ -> option_default) in
-
- let rec type_collect res = function
- TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
- | TC.Array(ty) -> type_collect res ty
- | TC.MetaType(tyname,TC.Saved,_) -> bind [tyname] res
- | TC.SignedT(_,Some ty) -> type_collect res ty
- | ty -> res in
-
- let astfvexpr recursor k e =
- let tymetas =
- match Ast.unwrap e with
- Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
- List.fold_left type_collect option_default type_list
- | _ -> [] in
- let vars =
- bind (k e)
- (match Ast.unwrap e with
- Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_)
- | Ast.MetaExprList(name,None,TC.Saved,_) -> [metaid name]
- | Ast.MetaExprList(name,Some (lenname,ls,_),ns,_) ->
- let namesaved =
- match ns with TC.Saved -> [metaid name] | _ -> [] in
- let lensaved =
- match ls with TC.Saved -> [metaid lenname] | _ -> [] in
- lensaved @ namesaved
- | _ -> option_default) in
- bind tymetas vars in
-
- let astfvtypeC recursor k ty =
- bind (k ty)
- (match Ast.unwrap ty with
- Ast.MetaType(name,TC.Saved,_) -> [metaid name]
- | _ -> option_default) in
-
- let astfvparam recursor k p =
- bind (k p)
- (match Ast.unwrap p with
- Ast.MetaParam(name,TC.Saved,_)
- | Ast.MetaParamList(name,None,_,_) -> [metaid name]
- | Ast.MetaParamList(name,Some (lenname,ls,_),ns,_) ->
- let namesaved =
- match ns with TC.Saved -> [metaid name] | _ -> [] in
- let lensaved =
- match ls with TC.Saved -> [metaid lenname] | _ -> [] in
- lensaved @ namesaved
- | _ -> option_default) in
-
- let astfvrule_elem recursor k re =
- (*within a rule_elem, pattern3 manages the coherence of the bindings*)
- bind (k re)
- (nub
- (match Ast.unwrap re with
- Ast.MetaRuleElem(name,TC.Saved,_) | Ast.MetaStmt(name,TC.Saved,_,_)
- | Ast.MetaStmtList(name,TC.Saved,_) -> [metaid name]
- | _ -> option_default)) in
-
- let mcode r e =
- match Ast.get_pos_var e with
- Ast.MetaPos(name,_,_,TC.Saved,_) -> [metaid name]
- | _ -> option_default in
-
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- astfvident astfvexpr donothing astfvtypeC donothing astfvparam
- donothing astfvrule_elem donothing donothing donothing donothing
-
-(* ---------------------------------------------------------------- *)
-
-(* For the rules under a given metavariable declaration, collect all of the
-variables that occur in the plus code *)
-
-let cip_mcodekind r mck =
- let process_anything_list_list anythings =
- let astfvs = collect_all_refs.V.combiner_anything in
- List.fold_left (@) []
- (List.map (function l -> List.fold_left (@) [] (List.map astfvs l))
- anythings) in
- match mck with
- Ast.MINUS(_,anythings) -> process_anything_list_list anythings
- | Ast.CONTEXT(_,befaft) ->
- (match befaft with
- Ast.BEFORE(ll) -> process_anything_list_list ll
- | Ast.AFTER(ll) -> process_anything_list_list ll
- | Ast.BEFOREAFTER(llb,lla) ->
- (process_anything_list_list lla) @
- (process_anything_list_list llb)
- | Ast.NOTHING -> [])
- | Ast.PLUS -> []
-
-let collect_in_plus_term =
- let bind x y = x @ y in
- let option_default = [] in
- let donothing r k e = k e in
-
- (* no positions in the + code *)
- let mcode r (_,_,mck,_) = cip_mcodekind r mck in
-
- (* case for things with bef/aft mcode *)
-
- let astfvrule_elem recursor k re =
- match Ast.unwrap re with
- Ast.FunHeader(bef,_,fi,nm,_,params,_) ->
- let fi_metas =
- List.concat
- (List.map
- (function
- Ast.FType(ty) -> collect_all_refs.V.combiner_fullType ty
- | _ -> [])
- fi) in
- let nm_metas = collect_all_refs.V.combiner_ident nm in
- let param_metas =
- match Ast.unwrap params with
- Ast.DOTS(params) | Ast.CIRCLES(params) ->
- List.concat
- (List.map
- (function p ->
- match Ast.unwrap p with
- Ast.VoidParam(t) | Ast.Param(t,_) ->
- collect_all_refs.V.combiner_fullType t
- | _ -> [])
- params)
- | _ -> failwith "not allowed for params" in
- bind fi_metas
- (bind nm_metas
- (bind param_metas
- (bind (cip_mcodekind recursor bef) (k re))))
- | Ast.Decl(bef,_,_) ->
- bind (cip_mcodekind recursor bef) (k re)
- | _ -> k re in
-
- let astfvstatement recursor k s =
- match Ast.unwrap s with
- Ast.IfThen(_,_,(_,_,_,aft)) | Ast.IfThenElse(_,_,_,_,(_,_,_,aft))
- | Ast.While(_,_,(_,_,_,aft)) | Ast.For(_,_,(_,_,_,aft))
- | Ast.Iterator(_,_,(_,_,_,aft)) ->
- bind (k s) (cip_mcodekind recursor aft)
- | _ -> k s in
-
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing
- donothing astfvrule_elem astfvstatement donothing donothing donothing
-
-let collect_in_plus minirules =
- nub
- (List.concat
- (List.map collect_in_plus_term.V.combiner_top_level minirules))
-
-(* ---------------------------------------------------------------- *)
-
-(* For the rules under a given metavariable declaration, collect all of the
-variables that occur only once and more than once in the minus code *)
-
-let collect_all_multirefs minirules =
- let refs = List.map collect_all_refs.V.combiner_top_level minirules in
- collect_unitary_nonunitary (List.concat refs)
-
-(* ---------------------------------------------------------------- *)
-
-(* classify as unitary (no binding) or nonunitary (env binding) or saved
-(witness binding) *)
-
-let classify_variables metavars minirules used_after =
- let metavars = List.map Ast.get_meta_name metavars in
- let (unitary,nonunitary) = collect_all_multirefs minirules in
- let inplus = collect_in_plus minirules in
-
- let donothing r k e = k e in
- let check_unitary name inherited =
- if List.mem name inplus or List.mem name used_after
- then TC.Saved
- else if not inherited && List.mem name unitary
- then TC.Unitary
- else TC.Nonunitary in
-
- let get_option f = function Some x -> Some (f x) | None -> None in
-
- let classify (name,_,_,_) =
- let inherited = not (List.mem name metavars) in
- (check_unitary name inherited,inherited) in
-
- let mcode mc =
- match Ast.get_pos_var mc with
- Ast.MetaPos(name,constraints,per,unitary,inherited) ->
- let (unitary,inherited) = classify name in
- Ast.set_pos_var (Ast.MetaPos(name,constraints,per,unitary,inherited))
- mc
- | _ -> mc in
-
- let ident r k e =
- let e = k e in
- match Ast.unwrap e with
- Ast.MetaId(name,constraints,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaId(name,constraints,unitary,inherited))
- | Ast.MetaFunc(name,constraints,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaFunc(name,constraints,unitary,inherited))
- | Ast.MetaLocalFunc(name,constraints,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaLocalFunc(name,constraints,unitary,inherited))
- | _ -> e in
-
- let rec type_infos = function
- TC.ConstVol(cv,ty) -> TC.ConstVol(cv,type_infos ty)
- | TC.Pointer(ty) -> TC.Pointer(type_infos ty)
- | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty)
- | TC.Array(ty) -> TC.Array(type_infos ty)
- | TC.MetaType(name,_,_) ->
- let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
- Type_cocci.MetaType(name,unitary,inherited)
- | TC.SignedT(sgn,Some ty) -> TC.SignedT(sgn,Some (type_infos ty))
- | ty -> ty in
-
- let expression r k e =
- let e = k e in
- match Ast.unwrap e with
- Ast.MetaErr(name,constraints,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaErr(name,constraints,unitary,inherited))
- | Ast.MetaExpr(name,constraints,_,ty,form,_) ->
- let (unitary,inherited) = classify name in
- let ty = get_option (List.map type_infos) ty in
- Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited))
- | Ast.MetaExprList(name,None,_,_) ->
- (* lenname should have the same properties of being unitary or
- inherited as name *)
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaExprList(name,None,unitary,inherited))
- | Ast.MetaExprList(name,Some(lenname,_,_),_,_) ->
- (* lenname should have the same properties of being unitary or
- inherited as name *)
- let (unitary,inherited) = classify name in
- let (lenunitary,leninherited) = classify lenname in
- Ast.rewrap e
- (Ast.MetaExprList
- (name,Some(lenname,lenunitary,leninherited),unitary,inherited))
- | _ -> e in
-
- let typeC r k e =
- let e = k e in
- match Ast.unwrap e with
- Ast.MetaType(name,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaType(name,unitary,inherited))
- | _ -> e in
-
- let param r k e =
- let e = k e in
- match Ast.unwrap e with
- Ast.MetaParam(name,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaParam(name,unitary,inherited))
- | Ast.MetaParamList(name,None,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaParamList(name,None,unitary,inherited))
- | Ast.MetaParamList(name,Some (lenname,_,_),_,_) ->
- let (unitary,inherited) = classify name in
- let (lenunitary,leninherited) = classify lenname in
- Ast.rewrap e
- (Ast.MetaParamList
- (name,Some (lenname,lenunitary,leninherited),unitary,inherited))
- | _ -> e in
-
- let rule_elem r k e =
- let e = k e in
- match Ast.unwrap e with
- Ast.MetaStmt(name,_,msi,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaStmt(name,unitary,msi,inherited))
- | Ast.MetaStmtList(name,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaStmtList(name,unitary,inherited))
- | _ -> e in
-
- let fn = V.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- ident expression donothing typeC donothing param donothing rule_elem
- donothing donothing donothing donothing in
-
- List.map fn.V.rebuilder_top_level minirules
-
-(* ---------------------------------------------------------------- *)
-
-(* For a minirule, collect the set of non-local (not in "bound") variables that
-are referenced. Store them in a hash table. *)
-
-(* bound means the metavariable was declared previously, not locally *)
-
-(* Highly inefficient, because we call collect_all_refs on nested code
-multiple times. But we get the advantage of not having too many variants
-of the same functions. *)
-
-(* Inherited doesn't include position constraints. If they are not bound
-then there is no constraint. *)
-
-let astfvs metavars bound =
- let fresh =
- List.fold_left
- (function prev ->
- function
- Ast.MetaFreshIdDecl(_,_) as x -> (Ast.get_meta_name x)::prev
- | _ -> prev)
- [] metavars in
-
- let collect_fresh = List.filter (function x -> List.mem x fresh) in
-
- (* cases for the elements of anything *)
- let astfvrule_elem recursor k re =
- let minus_free = nub (collect_all_refs.V.combiner_rule_elem re) in
- let minus_nc_free =
- nub (collect_non_constraint_refs.V.combiner_rule_elem re) in
- let plus_free = collect_in_plus_term.V.combiner_rule_elem re in
- let free = Common.union_set minus_free plus_free in
- let nc_free = Common.union_set minus_nc_free plus_free in
- let unbound =
- List.filter (function x -> not(List.mem x bound)) free in
- let inherited =
- List.filter (function x -> List.mem x bound) nc_free in
- let munbound =
- List.filter (function x -> not(List.mem x bound)) minus_free in
- {(k re) with
- Ast.free_vars = unbound;
- Ast.minus_free_vars = munbound;
- Ast.fresh_vars = collect_fresh unbound;
- Ast.inherited = inherited;
- Ast.saved_witness = []} in
-
- let astfvstatement recursor k s =
- let minus_free = nub (collect_all_refs.V.combiner_statement s) in
- let minus_nc_free =
- nub (collect_non_constraint_refs.V.combiner_statement s) in
- let plus_free = collect_in_plus_term.V.combiner_statement s in
- let free = Common.union_set minus_free plus_free in
- let nc_free = Common.union_set minus_nc_free plus_free in
- let classify free minus_free =
- let (unbound,inherited) =
- List.partition (function x -> not(List.mem x bound)) free in
- let munbound =
- List.filter (function x -> not(List.mem x bound)) minus_free in
- (unbound,munbound,collect_fresh unbound,inherited) in
- let res = k s in
- let s =
- match Ast.unwrap res with
- Ast.IfThen(header,branch,(_,_,_,aft)) ->
- let (unbound,_,fresh,inherited) =
- classify (cip_mcodekind collect_in_plus_term aft) [] in
- Ast.IfThen(header,branch,(unbound,fresh,inherited,aft))
- | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
- let (unbound,_,fresh,inherited) =
- classify (cip_mcodekind collect_in_plus_term aft) [] in
- Ast.IfThenElse(header,branch1,els,branch2,
- (unbound,fresh,inherited,aft))
- | Ast.While(header,body,(_,_,_,aft)) ->
- let (unbound,_,fresh,inherited) =
- classify (cip_mcodekind collect_in_plus_term aft) [] in
- Ast.While(header,body,(unbound,fresh,inherited,aft))
- | Ast.For(header,body,(_,_,_,aft)) ->
- let (unbound,_,fresh,inherited) =
- classify (cip_mcodekind collect_in_plus_term aft) [] in
- Ast.For(header,body,(unbound,fresh,inherited,aft))
- | Ast.Iterator(header,body,(_,_,_,aft)) ->
- let (unbound,_,fresh,inherited) =
- classify (cip_mcodekind collect_in_plus_term aft) [] in
- Ast.Iterator(header,body,(unbound,fresh,inherited,aft))
- | s -> s in
-
- let (unbound,munbound,fresh,_) = classify free minus_free in
- let inherited =
- List.filter (function x -> List.mem x bound) nc_free in
- {res with
- Ast.node = s;
- Ast.free_vars = unbound;
- Ast.minus_free_vars = munbound;
- Ast.fresh_vars = collect_fresh unbound;
- Ast.inherited = inherited;
- Ast.saved_witness = []} in
-
- let astfvstatement_dots recursor k sd =
- let minus_free = nub (collect_all_refs.V.combiner_statement_dots sd) in
- let minus_nc_free =
- nub (collect_non_constraint_refs.V.combiner_statement_dots sd) in
- let plus_free = collect_in_plus_term.V.combiner_statement_dots sd in
- let free = Common.union_set minus_free plus_free in
- let nc_free = Common.union_set minus_nc_free plus_free in
- let unbound =
- List.filter (function x -> not(List.mem x bound)) free in
- let inherited =
- List.filter (function x -> List.mem x bound) nc_free in
- let munbound =
- List.filter (function x -> not(List.mem x bound)) minus_free in
- {(k sd) with
- Ast.free_vars = unbound;
- Ast.minus_free_vars = munbound;
- Ast.fresh_vars = collect_fresh unbound;
- Ast.inherited = inherited;
- Ast.saved_witness = []} in
-
- let astfvtoplevel recursor k tl =
- let saved = collect_saved.V.combiner_top_level tl in
- {(k tl) with Ast.saved_witness = saved} in
-
- let mcode x = x in
- let donothing r k e = k e in
-
- V.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing astfvstatement_dots donothing
- donothing donothing donothing donothing donothing donothing donothing
- astfvrule_elem astfvstatement donothing astfvtoplevel donothing
-
-(*
-let collect_astfvs rules =
- let rec loop bound = function
- [] -> []
- | (metavars,(nm,rule_info,minirules))::rules ->
- let bound =
- Common.minus_set bound (List.map Ast.get_meta_name metavars) in
- (nm,rule_info,
- (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
- (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
- loop [] rules
-*)
-
-let collect_astfvs rules =
- let rec loop bound = function
- [] -> []
- | (metavars, rule)::rules ->
- match rule with
- Ast.ScriptRule (_,_,_,_) ->
- (* bound stays as is because script rules have no names, so no
- inheritance is possible *)
- rule::(loop bound rules)
- | Ast.CocciRule (nm, rule_info, minirules, isexp, ruletype) ->
- let bound =
- Common.minus_set bound (List.map Ast.get_meta_name metavars) in
- (Ast.CocciRule
- (nm, rule_info,
- (List.map (astfvs metavars bound).V.rebuilder_top_level
- minirules),
- isexp, ruletype))::
- (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
- loop [] rules
-
-(* ---------------------------------------------------------------- *)
-(* position variables that appear as a constraint on another position variable.
-a position variable also cannot appear both positively and negatively in a
-single rule. *)
-
-let get_neg_pos_list (_,rule) used_after_list =
- let donothing r k e = k e in
- let bind (p1,np1) (p2,np2) =
- (Common.union_set p1 p2, Common.union_set np1 np2) in
- let option_default = ([],[]) in
- let metaid (x,_,_,_) = x in
- let mcode r mc =
- match Ast.get_pos_var mc with
- Ast.MetaPos(name,constraints,Ast.PER,_,_) ->
- ([metaid name],constraints)
- | Ast.MetaPos(name,constraints,Ast.ALL,_,_) ->
- ([],(metaid name)::constraints)
- | _ -> option_default in
- let v =
- V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing in
- match rule with
- Ast.CocciRule(_,_,minirules,_,_) ->
- List.map
- (function toplevel ->
- let (positions,neg_positions) = v.V.combiner_top_level toplevel in
- (if List.exists (function p -> List.mem p neg_positions) positions
- then
- failwith
- "a variable cannot be used both as a position and a constraint");
- neg_positions)
- minirules
- | Ast.ScriptRule _ -> [] (*no negated positions*)
-
-(* ---------------------------------------------------------------- *)
-
-(* collect used after lists, per minirule *)
-
-(* defined is a list of variables that were declared in a previous metavar
-declaration *)
-
-(* Top-level used after: For each rule collect the set of variables that
-are inherited, ie used but not defined. These are accumulated back to
-their point of definition. *)
-
-
-let collect_top_level_used_after metavar_rule_list =
- let (used_after,used_after_lists) =
- List.fold_right
- (function (metavar_list,r) ->
- function (used_after,used_after_lists) ->
- let locally_defined = List.map Ast.get_meta_name metavar_list in
- let continue_propagation =
- List.filter (function x -> not(List.mem x locally_defined))
- used_after in
- let free_vars =
- match r with
- Ast.ScriptRule (_,_,mv,_) ->
- List.map (function (_,(r,v)) -> (r,v)) mv
- | Ast.CocciRule (_,_,rule,_,_) ->
- Common.union_set (nub (collect_all_rule_refs rule))
- (collect_in_plus rule) in
- let inherited =
- List.filter (function x -> not (List.mem x locally_defined))
- free_vars in
- (Common.union_set inherited continue_propagation,
- used_after::used_after_lists))
- metavar_rule_list ([],[]) in
- match used_after with
- [] -> used_after_lists
- | _ ->
- failwith
- (Printf.sprintf "collect_top_level_used_after: unbound variables %s"
- (String.concat " " (List.map (function (_,x) -> x) used_after)))
-
-let collect_local_used_after metavars minirules used_after =
- let locally_defined = List.map Ast.get_meta_name metavars in
- let rec loop defined = function
- [] -> (used_after,[],[])
- | minirule::rest ->
- let free_vars =
- Common.union_set
- (nub (collect_all_minirule_refs minirule))
- (collect_in_plus_term.V.combiner_top_level minirule) in
- let local_free_vars =
- List.filter (function x -> List.mem x locally_defined) free_vars in
- let new_defined = Common.union_set local_free_vars defined in
- let (mini_used_after,fvs_lists,mini_used_after_lists) =
- loop new_defined rest in
- let local_used = Common.union_set local_free_vars mini_used_after in
- let (new_used_after,new_list) =
- List.partition (function x -> List.mem x defined) mini_used_after in
- let new_used_after = Common.union_set local_used new_used_after in
- (new_used_after,free_vars::fvs_lists,
- new_list::mini_used_after_lists) in
- let (_,fvs_lists,used_after_lists) = loop [] minirules in
- (fvs_lists,used_after_lists)
-
-
-let collect_used_after metavar_rule_list =
- let used_after_lists = collect_top_level_used_after metavar_rule_list in
- List.map2
- (function (metavars,r) ->
- function used_after ->
- match r with
- Ast.ScriptRule (_,_,mv,_) -> ([], [used_after])
- | Ast.CocciRule (name, rule_info, minirules, _,_) ->
- collect_local_used_after metavars minirules used_after
- )
- metavar_rule_list used_after_lists
-
-(* ---------------------------------------------------------------- *)
-(* entry point *)
-
-let free_vars rules =
- let metavars = List.map (function (mv,rule) -> mv) rules in
- let (fvs_lists,used_after_lists) = List.split (collect_used_after rules) in
- let neg_pos_lists = List.map2 get_neg_pos_list rules used_after_lists in
- let positions_list = (* for all rules, assume all positions are used after *)
- List.map
- (function (mv, r) ->
- match r with
- Ast.ScriptRule _ -> []
- | Ast.CocciRule (_,_,rule,_,_) ->
- let positions =
- List.fold_left
- (function prev ->
- function Ast.MetaPosDecl(_,nm) -> nm::prev | _ -> prev)
- [] mv in
- List.map (function _ -> positions) rule)
- rules in
- let new_rules =
- List.map2
- (function (mv,r) ->
- function ua ->
- match r with
- Ast.ScriptRule _ -> r
- | Ast.CocciRule (nm, rule_info, r, is_exp,ruletype) ->
- Ast.CocciRule
- (nm, rule_info, classify_variables mv r (List.concat ua),
- is_exp,ruletype))
- rules used_after_lists in
- let new_rules = collect_astfvs (List.combine metavars new_rules) in
- (metavars,new_rules,
- fvs_lists,neg_pos_lists,used_after_lists,positions_list)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* create an index for each constructor *)
-(* current max is 147 *)
-
-(* doesn't really work - requires that identical terms with no token
-subterms (eg dots) not appear on the same line *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-
-(* if a dot list is empty, add the starting line of the dot list to the
-address. Otherwise add 0. An empty dot list should only match with another
-empty one. *)
-let expression_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 1::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 2::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 3::(if l = [] then [ln] else [0])
-
-let initialiser_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 113::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 114::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 115::(if l = [] then [ln] else [0])
-
-let parameter_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 4::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 5::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 6::(if l = [] then [ln] else [0])
-
-let statement_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 7::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 8::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 9::(if l = [] then [ln] else [0])
-
-let declaration_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 134::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 135::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 136::(if l = [] then [ln] else [0])
-
-let case_line_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 138::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 139::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 140::(if l = [] then [ln] else [0])
-
-let ident i =
- match Ast0.unwrap i with
- Ast0.Id(name) -> [10]
- | Ast0.MetaId(name,_,_) -> [11]
- | Ast0.MetaFunc(name,_,_) -> [12]
- | Ast0.MetaLocalFunc(name,_,_) -> [13]
- | Ast0.OptIdent(id) -> [14]
- | Ast0.UniqueIdent(id) -> [15]
-
-let expression e =
- match Ast0.unwrap e with
- Ast0.Ident(id) -> [17]
- | Ast0.Constant(const) -> [18]
- | Ast0.FunCall(fn,lp,args,rp) -> [19]
- | Ast0.Assignment(left,op,right,simple) -> [20]
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) -> [21]
- | Ast0.Postfix(exp,op) -> [22]
- | Ast0.Infix(exp,op) -> [23]
- | Ast0.Unary(exp,op) -> [24]
- | Ast0.Binary(left,op,right) -> [25]
- | Ast0.Nested(left,op,right) -> failwith "nested in index not possible"
- | Ast0.Paren(lp,exp,rp) -> [26]
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) -> [27]
- | Ast0.RecordAccess(exp,pt,field) -> [28]
- | Ast0.RecordPtAccess(exp,ar,field) -> [29]
- | Ast0.Cast(lp,ty,rp,exp) -> [30]
- | Ast0.SizeOfExpr(szf,exp) -> [98] (* added after *)
- | Ast0.SizeOfType(szf,lp,ty,rp) -> [99] (* added after *)
- | Ast0.TypeExp(ty) -> [123] (* added after *)
- | Ast0.MetaErr(name,_,_) -> [32]
- | Ast0.MetaExpr(name,_,ty,_,_) -> [33]
- | Ast0.MetaExprList(name,_,_) -> [34]
- | Ast0.EComma(cm) -> [35]
- | Ast0.DisjExpr(_,expr_list,_,_) -> [36]
- | Ast0.NestExpr(_,expr_dots,_,_,_) -> [37]
- | Ast0.Edots(dots,whencode) -> [38]
- | Ast0.Ecircles(dots,whencode) -> [39]
- | Ast0.Estars(dots,whencode) -> [40]
- | Ast0.OptExp(exp) -> [41]
- | Ast0.UniqueExp(exp) -> [42]
-
-let typeC t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) -> [44]
- | Ast0.BaseType(ty,strings) -> [48]
- | Ast0.Signed(sign,ty) -> [129]
- | Ast0.Pointer(ty,star) -> [49]
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) -> [131]
- | Ast0.FunctionType(ty,lp1,params,rp1) -> [132]
- | Ast0.Array(ty,lb,size,rb) -> [50]
- | Ast0.EnumName(kind,name) -> [146]
- | Ast0.StructUnionName(kind,name) -> [51]
- | Ast0.StructUnionDef(ty,lb,decls,rb) -> [117]
- | Ast0.TypeName(name) -> [52]
- | Ast0.MetaType(name,_) -> [53]
- | Ast0.DisjType(_,type_list,_,_) -> [130]
- | Ast0.OptType(ty) -> [45]
- | Ast0.UniqueType(ty) -> [46]
-
-let declaration d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,exp,sem) -> [54]
- | Ast0.UnInit(stg,ty,id,sem) -> [55]
- | Ast0.MacroDecl(name,lp,args,rp,sem) -> [137]
- | Ast0.TyDecl(ty,sem) -> [116]
- | Ast0.Typedef(stg,ty,id,sem) -> [143]
- | Ast0.DisjDecl(_,decls,_,_) -> [97] (* added after *)
- | Ast0.Ddots(dots,whencode) -> [133]
- | Ast0.OptDecl(decl) -> [56]
- | Ast0.UniqueDecl(decl) -> [57]
-
-let initialiser i =
- match Ast0.unwrap i with
- Ast0.InitExpr(exp) -> [102] (* added after *)
- | Ast0.InitList(lb,initlist,rb) -> [103]
- | Ast0.InitGccDotName(dot,name,eq,ini) -> [104]
- | Ast0.InitGccName(name,eq,ini) -> [105]
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) -> [106]
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) -> [107]
- | Ast0.IComma(cm) -> [108]
- | Ast0.Idots(d,whencode) -> [109]
- | Ast0.OptIni(id) -> [110]
- | Ast0.UniqueIni(id) -> [111]
-
-let parameterTypeDef p =
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> [59]
- | Ast0.Param(ty,id) -> [60]
- | Ast0.MetaParam(name,_) -> [61]
- | Ast0.MetaParamList(name,_,_) -> [62]
- | Ast0.PComma(cm) -> [63]
- | Ast0.Pdots(dots) -> [64]
- | Ast0.Pcircles(dots) -> [65]
- | Ast0.OptParam(param) -> [66]
- | Ast0.UniqueParam(param) -> [67]
-
-let statement s =
- match Ast0.unwrap s with
- Ast0.FunDecl(bef,fninfo,name,lp,params,rp,lbrace,body,rbrace) -> [68]
- | Ast0.Decl(bef,decl) -> [69]
- | Ast0.Seq(lbrace,body,rbrace) -> [70]
- | Ast0.ExprStatement(exp,sem) -> [71]
- | Ast0.IfThen(iff,lp,exp,rp,branch1,aft) -> [72]
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft) -> [73]
- | Ast0.While(whl,lp,exp,rp,body,_) -> [74]
- | Ast0.Do(d,body,whl,lp,exp,rp,sem) -> [75]
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,_) -> [76]
- | Ast0.Iterator(nm,lp,args,rp,body,_) -> [142]
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) -> [125]
- | Ast0.Break(br,sem) -> [100]
- | Ast0.Continue(cont,sem) -> [101]
- | Ast0.Label(l,dd) -> [144]
- | Ast0.Goto(goto,l,sem) -> [145]
- | Ast0.Return(ret,sem) -> [77]
- | Ast0.ReturnExpr(ret,exp,sem) -> [78]
- | Ast0.MetaStmt(name,_) -> [79]
- | Ast0.MetaStmtList(name,_) -> [80]
- | Ast0.Disj(_,statement_dots_list,_,_) -> [81]
- | Ast0.Nest(_,stmt_dots,_,_,_) -> [82]
- | Ast0.Exp(exp) -> [83]
- | Ast0.TopExp(exp) -> [141]
- | Ast0.Ty(ty) -> [124]
- | Ast0.TopInit(init) -> [146]
- | Ast0.Dots(d,whencode) -> [84]
- | Ast0.Circles(d,whencode) -> [85]
- | Ast0.Stars(d,whencode) -> [86]
- | Ast0.Include(inc,name) -> [118]
- | Ast0.Define(def,id,params,body) -> [119]
- | Ast0.OptStm(re) -> [87]
- | Ast0.UniqueStm(re) -> [88]
-
-let case_line c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) -> [126]
- | Ast0.Case(case,exp,colon,code) -> [127]
- | Ast0.OptCase(case) -> [128]
-
-let top_level t =
- match Ast0.unwrap t with
- Ast0.DECL(stmt) -> [90]
- | Ast0.FILEINFO(old_file,new_file) -> [92]
- | Ast0.CODE(stmt_dots) -> [94]
- | Ast0.ERRORWORDS(exps) -> [95]
- | Ast0.OTHER(_) -> [96]
-
-(* 99-101 already used *)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* create an index for each constructor *)
-(* current max is 147, but 107 is free *)
-
-(* doesn't really work - requires that identical terms with no token
-subterms (eg dots) not appear on the same line *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-
-(* if a dot list is empty, add the starting line of the dot list to the
-address. Otherwise add 0. An empty dot list should only match with another
-empty one. *)
-let expression_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 1::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 2::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 3::(if l = [] then [ln] else [0])
-
-let initialiser_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 113::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 114::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 115::(if l = [] then [ln] else [0])
-
-let parameter_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 4::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 5::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 6::(if l = [] then [ln] else [0])
-
-let statement_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 7::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 8::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 9::(if l = [] then [ln] else [0])
-
-let declaration_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 134::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 135::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 136::(if l = [] then [ln] else [0])
-
-let case_line_dots d =
- let ln = (Ast0.get_info d).Ast0.line_start in
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> 138::(if l = [] then [ln] else [0])
- | Ast0.CIRCLES(l) -> 139::(if l = [] then [ln] else [0])
- | Ast0.STARS(l) -> 140::(if l = [] then [ln] else [0])
-
-let ident i =
- match Ast0.unwrap i with
- Ast0.Id(name) -> [10]
- | Ast0.MetaId(name,_,_) -> [11]
- | Ast0.MetaFunc(name,_,_) -> [12]
- | Ast0.MetaLocalFunc(name,_,_) -> [13]
- | Ast0.OptIdent(id) -> [14]
- | Ast0.UniqueIdent(id) -> [15]
-
-let expression e =
- match Ast0.unwrap e with
- Ast0.Ident(id) -> [17]
- | Ast0.Constant(const) -> [18]
- | Ast0.FunCall(fn,lp,args,rp) -> [19]
- | Ast0.Assignment(left,op,right,simple) -> [20]
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) -> [21]
- | Ast0.Postfix(exp,op) -> [22]
- | Ast0.Infix(exp,op) -> [23]
- | Ast0.Unary(exp,op) -> [24]
- | Ast0.Binary(left,op,right) -> [25]
- | Ast0.Nested(left,op,right) -> failwith "nested in index not possible"
- | Ast0.Paren(lp,exp,rp) -> [26]
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) -> [27]
- | Ast0.RecordAccess(exp,pt,field) -> [28]
- | Ast0.RecordPtAccess(exp,ar,field) -> [29]
- | Ast0.Cast(lp,ty,rp,exp) -> [30]
- | Ast0.SizeOfExpr(szf,exp) -> [98] (* added after *)
- | Ast0.SizeOfType(szf,lp,ty,rp) -> [99] (* added after *)
- | Ast0.TypeExp(ty) -> [123] (* added after *)
- | Ast0.MetaErr(name,_,_) -> [32]
- | Ast0.MetaExpr(name,_,ty,_,_) -> [33]
- | Ast0.MetaExprList(name,_,_) -> [34]
- | Ast0.EComma(cm) -> [35]
- | Ast0.DisjExpr(_,expr_list,_,_) -> [36]
- | Ast0.NestExpr(_,expr_dots,_,_,_) -> [37]
- | Ast0.Edots(dots,whencode) -> [38]
- | Ast0.Ecircles(dots,whencode) -> [39]
- | Ast0.Estars(dots,whencode) -> [40]
- | Ast0.OptExp(exp) -> [41]
- | Ast0.UniqueExp(exp) -> [42]
-
-let typeC t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) -> [44]
- | Ast0.BaseType(ty,strings) -> [48]
- | Ast0.Signed(sign,ty) -> [129]
- | Ast0.Pointer(ty,star) -> [49]
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) -> [131]
- | Ast0.FunctionType(ty,lp1,params,rp1) -> [132]
- | Ast0.Array(ty,lb,size,rb) -> [50]
- | Ast0.EnumName(kind,name) -> [146]
- | Ast0.StructUnionName(kind,name) -> [51]
- | Ast0.StructUnionDef(ty,lb,decls,rb) -> [117]
- | Ast0.TypeName(name) -> [52]
- | Ast0.MetaType(name,_) -> [53]
- | Ast0.DisjType(_,type_list,_,_) -> [130]
- | Ast0.OptType(ty) -> [45]
- | Ast0.UniqueType(ty) -> [46]
-
-let declaration d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,exp,sem) -> [54]
- | Ast0.UnInit(stg,ty,id,sem) -> [55]
- | Ast0.MacroDecl(name,lp,args,rp,sem) -> [137]
- | Ast0.TyDecl(ty,sem) -> [116]
- | Ast0.Typedef(stg,ty,id,sem) -> [143]
- | Ast0.DisjDecl(_,decls,_,_) -> [97] (* added after *)
- | Ast0.Ddots(dots,whencode) -> [133]
- | Ast0.OptDecl(decl) -> [56]
- | Ast0.UniqueDecl(decl) -> [57]
-
-let initialiser i =
- match Ast0.unwrap i with
- Ast0.MetaInit(nm,_) -> [106] (* added after *)
- | Ast0.InitExpr(exp) -> [102]
- | Ast0.InitList(lb,initlist,rb) -> [103]
- | Ast0.InitGccExt(designators,eq,ini) -> [104]
- | Ast0.InitGccName(name,eq,ini) -> [105]
- | Ast0.IComma(cm) -> [108]
- | Ast0.Idots(d,whencode) -> [109]
- | Ast0.OptIni(id) -> [110]
- | Ast0.UniqueIni(id) -> [111]
-
-let parameterTypeDef p =
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> [59]
- | Ast0.Param(ty,id) -> [60]
- | Ast0.MetaParam(name,_) -> [61]
- | Ast0.MetaParamList(name,_,_) -> [62]
- | Ast0.PComma(cm) -> [63]
- | Ast0.Pdots(dots) -> [64]
- | Ast0.Pcircles(dots) -> [65]
- | Ast0.OptParam(param) -> [66]
- | Ast0.UniqueParam(param) -> [67]
-
-let statement s =
- match Ast0.unwrap s with
- Ast0.FunDecl(bef,fninfo,name,lp,params,rp,lbrace,body,rbrace) -> [68]
- | Ast0.Decl(bef,decl) -> [69]
- | Ast0.Seq(lbrace,body,rbrace) -> [70]
- | Ast0.ExprStatement(exp,sem) -> [71]
- | Ast0.IfThen(iff,lp,exp,rp,branch1,aft) -> [72]
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft) -> [73]
- | Ast0.While(whl,lp,exp,rp,body,_) -> [74]
- | Ast0.Do(d,body,whl,lp,exp,rp,sem) -> [75]
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,_) -> [76]
- | Ast0.Iterator(nm,lp,args,rp,body,_) -> [142]
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) -> [125]
- | Ast0.Break(br,sem) -> [100]
- | Ast0.Continue(cont,sem) -> [101]
- | Ast0.Label(l,dd) -> [144]
- | Ast0.Goto(goto,l,sem) -> [145]
- | Ast0.Return(ret,sem) -> [77]
- | Ast0.ReturnExpr(ret,exp,sem) -> [78]
- | Ast0.MetaStmt(name,_) -> [79]
- | Ast0.MetaStmtList(name,_) -> [80]
- | Ast0.Disj(_,statement_dots_list,_,_) -> [81]
- | Ast0.Nest(_,stmt_dots,_,_,_) -> [82]
- | Ast0.Exp(exp) -> [83]
- | Ast0.TopExp(exp) -> [141]
- | Ast0.Ty(ty) -> [124]
- | Ast0.TopInit(init) -> [146]
- | Ast0.Dots(d,whencode) -> [84]
- | Ast0.Circles(d,whencode) -> [85]
- | Ast0.Stars(d,whencode) -> [86]
- | Ast0.Include(inc,name) -> [118]
- | Ast0.Define(def,id,params,body) -> [119]
- | Ast0.OptStm(re) -> [87]
- | Ast0.UniqueStm(re) -> [88]
-
-let case_line c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) -> [126]
- | Ast0.Case(case,exp,colon,code) -> [127]
- | Ast0.OptCase(case) -> [128]
-
-let top_level t =
- match Ast0.unwrap t with
- Ast0.DECL(stmt) -> [90]
- | Ast0.FILEINFO(old_file,new_file) -> [92]
- | Ast0.CODE(stmt_dots) -> [94]
- | Ast0.ERRORWORDS(exps) -> [95]
- | Ast0.OTHER(_) -> [96]
-
-(* 99-101 already used *)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* The error message "no available token to attach to" often comes in an
-argument list of unbounded length. In this case, one should move a comma so
-that there is a comma after the + code. *)
-
-(* Start at all of the corresponding BindContext nodes in the minus and
-plus trees, and traverse their children. We take the same strategy as
-before: collect the list of minus/context nodes/tokens and the list of plus
-tokens, and then merge them. *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module V0 = Visitor_ast0
-module CN = Context_neg
-
-let empty_isos = ref false
-
-let get_option f = function
- None -> []
- | Some x -> f x
-
-(* --------------------------------------------------------------------- *)
-(* Collect root and all context nodes in a tree *)
-
-let collect_context e =
- let bind x y = x @ y in
- let option_default = [] in
-
- let mcode _ = [] in
-
- let donothing builder r k e =
- match Ast0.get_mcodekind e with
- Ast0.CONTEXT(_) -> (builder e) :: (k e)
- | _ -> k e in
-
-(* special case for everything that contains whencode, so that we skip over
-it *)
- let expression r k e =
- donothing Ast0.expr r k
- (Ast0.rewrap e
- (match Ast0.unwrap e with
- Ast0.NestExpr(starter,exp,ender,whencode,multi) ->
- Ast0.NestExpr(starter,exp,ender,None,multi)
- | Ast0.Edots(dots,whencode) -> Ast0.Edots(dots,None)
- | Ast0.Ecircles(dots,whencode) -> Ast0.Ecircles(dots,None)
- | Ast0.Estars(dots,whencode) -> Ast0.Estars(dots,None)
- | e -> e)) in
-
- let initialiser r k i =
- donothing Ast0.ini r k
- (Ast0.rewrap i
- (match Ast0.unwrap i with
- Ast0.Idots(dots,whencode) -> Ast0.Idots(dots,None)
- | i -> i)) in
-
- let statement r k s =
- donothing Ast0.stmt r k
- (Ast0.rewrap s
- (match Ast0.unwrap s with
- Ast0.Nest(started,stm_dots,ender,whencode,multi) ->
- Ast0.Nest(started,stm_dots,ender,[],multi)
- | Ast0.Dots(dots,whencode) -> Ast0.Dots(dots,[])
- | Ast0.Circles(dots,whencode) -> Ast0.Circles(dots,[])
- | Ast0.Stars(dots,whencode) -> Ast0.Stars(dots,[])
- | s -> s)) in
-
- let topfn r k e = Ast0.TopTag(e) :: (k e) in
-
- let res =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- (donothing Ast0.dotsExpr) (donothing Ast0.dotsInit)
- (donothing Ast0.dotsParam) (donothing Ast0.dotsStmt)
- (donothing Ast0.dotsDecl) (donothing Ast0.dotsCase)
- (donothing Ast0.ident) expression (donothing Ast0.typeC) initialiser
- (donothing Ast0.param) (donothing Ast0.decl) statement
- (donothing Ast0.case_line) topfn in
- res.V0.combiner_top_level e
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* collect the possible join points, in order, among the children of a
-BindContext. Dots are not allowed. Nests and disjunctions are no problem,
-because their delimiters take up a line by themselves *)
-
-(* An Unfavored token is one that is in a BindContext node; using this causes
- the node to become Neither, meaning that isomorphisms can't be applied *)
-(* Toplevel is for the bef token of a function declaration and is for
-attaching top-level definitions that should come before the complete
-declaration *)
-type minus_join_point = Favored | Unfavored | Toplevel | Decl
-
-(* Maps the index of a node to the indices of the mcodes it contains *)
-let root_token_table = (Hashtbl.create(50) : (int, int list) Hashtbl.t)
-
-let create_root_token_table minus =
- Hashtbl.iter
- (function tokens ->
- function (node,_) ->
- let key =
- match node with
- Ast0.DotsExprTag(d) -> Ast0.get_index d
- | Ast0.DotsInitTag(d) -> Ast0.get_index d
- | Ast0.DotsParamTag(d) -> Ast0.get_index d
- | Ast0.DotsStmtTag(d) -> Ast0.get_index d
- | Ast0.DotsDeclTag(d) -> Ast0.get_index d
- | Ast0.DotsCaseTag(d) -> Ast0.get_index d
- | Ast0.IdentTag(d) -> Ast0.get_index d
- | Ast0.ExprTag(d) -> Ast0.get_index d
- | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(d) -> Ast0.get_index d
- | Ast0.ParamTag(d) -> Ast0.get_index d
- | Ast0.InitTag(d) -> Ast0.get_index d
- | Ast0.DeclTag(d) -> Ast0.get_index d
- | Ast0.StmtTag(d) -> Ast0.get_index d
- | Ast0.CaseLineTag(d) -> Ast0.get_index d
- | Ast0.TopTag(d) -> Ast0.get_index d
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
- in
- Hashtbl.add root_token_table key tokens)
- CN.minus_table;
- List.iter
- (function r ->
- let index = Ast0.get_index r in
- try let _ = Hashtbl.find root_token_table index in ()
- with Not_found -> Hashtbl.add root_token_table index [])
- minus
-
-let collect_minus_join_points root =
- let root_index = Ast0.get_index root in
- let unfavored_tokens = Hashtbl.find root_token_table root_index in
- let bind x y = x @ y in
- let option_default = [] in
-
- let mcode (_,_,info,mcodekind,_) =
- if List.mem (info.Ast0.offset) unfavored_tokens
- then [(Unfavored,info,mcodekind)]
- else [(Favored,info,mcodekind)] in
-
- let do_nothing r k e =
- let info = Ast0.get_info e in
- let index = Ast0.get_index e in
- match Ast0.get_mcodekind e with
- (Ast0.MINUS(_)) as mc -> [(Favored,info,mc)]
- | (Ast0.CONTEXT(_)) as mc when not(index = root_index) ->
- (* This was unfavored at one point, but I don't remember why *)
- [(Favored,info,mc)]
- | _ -> k e in
-
-(* don't want to attach to the outside of DOTS, because metavariables can't
-bind to that; not good for isomorphisms *)
-
- let dots f k d =
- let multibind l =
- let rec loop = function
- [] -> option_default
- | [x] -> x
- | x::xs -> bind x (loop xs) in
- loop l in
-
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> multibind (List.map f l)
- | Ast0.CIRCLES(l) -> multibind (List.map f l)
- | Ast0.STARS(l) -> multibind (List.map f l) in
-
- let edots r k d = dots r.V0.combiner_expression k d in
- let idots r k d = dots r.V0.combiner_initialiser k d in
- let pdots r k d = dots r.V0.combiner_parameter k d in
- let sdots r k d = dots r.V0.combiner_statement k d in
- let ddots r k d = dots r.V0.combiner_declaration k d in
- let cdots r k d = dots r.V0.combiner_case_line k d in
-
- (* a case for everything that has a Opt *)
-
- let statement r k s =
- (*
- let redo_branched res (ifinfo,aftmc) =
- let redo fv info mc rest =
- let new_info = {info with Ast0.attachable_end = false} in
- List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
- match List.rev res with
- [(fv,info,mc)] ->
- (match mc with
- Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
- (* even for -, better for isos not to integrate code after an
- if into the if body.
- but the problem is that this can extend the region in
- which a variable is bound, because a variable bound in the
- aft node would seem to have to be live in the whole if,
- whereas we might like it to be live in only one branch.
- ie ideally, if we can keep the minus code in the right
- order, we would like to drop it as close to the bindings
- of its free variables. This could be anywhere in the minus
- code. Perhaps we would like to do this after the
- application of isomorphisms, though.
- *)
- redo fv info mc []
- | _ -> res)
- | (fv,info,mc)::rest ->
- (match mc with
- Ast0.CONTEXT(_) -> redo fv info mc rest
- | _ -> res)
- | _ -> failwith "unexpected empty code" in *)
- match Ast0.unwrap s with
- (* Ast0.IfThen(_,_,_,_,_,aft)
- | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
- | Ast0.While(_,_,_,_,_,aft)
- | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
- | Ast0.Iterator(_,_,_,_,_,aft) ->
- redo_branched (do_nothing r k s) aft*)
- | Ast0.FunDecl((info,bef),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- (Toplevel,info,bef)::(k s)
- | Ast0.Decl((info,bef),decl) -> (Decl,info,bef)::(k s)
- | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) ->
- mcode starter @ r.V0.combiner_statement_dots stmt_dots @ mcode ender
- | Ast0.Dots(d,whencode) | Ast0.Circles(d,whencode)
- | Ast0.Stars(d,whencode) -> mcode d (* ignore whencode *)
- | Ast0.OptStm s | Ast0.UniqueStm s ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_statement s
- | _ -> do_nothing r k s in
-
- let expression r k e =
- match Ast0.unwrap e with
- Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
- mcode starter @
- r.V0.combiner_expression_dots expr_dots @ mcode ender
- | Ast0.Edots(d,whencode) | Ast0.Ecircles(d,whencode)
- | Ast0.Estars(d,whencode) -> mcode d (* ignore whencode *)
- | Ast0.OptExp e | Ast0.UniqueExp e ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_expression e
- | _ -> do_nothing r k e in
-
- let ident r k e =
- match Ast0.unwrap e with
- Ast0.OptIdent i | Ast0.UniqueIdent i ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_ident i
- | _ -> do_nothing r k e in
-
- let typeC r k e =
- match Ast0.unwrap e with
- Ast0.OptType t | Ast0.UniqueType t ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_typeC t
- | _ -> do_nothing r k e in
-
- let decl r k e =
- match Ast0.unwrap e with
- Ast0.OptDecl d | Ast0.UniqueDecl d ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_declaration d
- | _ -> do_nothing r k e in
-
- let initialiser r k e =
- match Ast0.unwrap e with
- Ast0.Idots(d,whencode) -> mcode d (* ignore whencode *)
- | Ast0.OptIni i | Ast0.UniqueIni i ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_initialiser i
- | _ -> do_nothing r k e in
-
- let param r k e =
- match Ast0.unwrap e with
- Ast0.OptParam p | Ast0.UniqueParam p ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_parameter p
- | _ -> do_nothing r k e in
-
- let case_line r k e =
- match Ast0.unwrap e with
- Ast0.OptCase c ->
- (* put the + code on the thing, not on the opt *)
- r.V0.combiner_case_line c
- | _ -> do_nothing r k e in
-
- let do_top r k (e: Ast0.top_level) = k e in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- edots idots pdots sdots ddots cdots
- ident expression typeC initialiser param decl statement case_line do_top
-
-
-let call_collect_minus context_nodes :
- (int * (minus_join_point * Ast0.info * Ast0.mcodekind) list) list =
- List.map
- (function e ->
- match e with
- Ast0.DotsExprTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_expression_dots e)
- | Ast0.DotsInitTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_initialiser_list e)
- | Ast0.DotsParamTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_parameter_list e)
- | Ast0.DotsStmtTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_statement_dots e)
- | Ast0.DotsDeclTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_declaration_dots e)
- | Ast0.DotsCaseTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_case_line_dots e)
- | Ast0.IdentTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_ident e)
- | Ast0.ExprTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_expression e)
- | Ast0.ArgExprTag(e) | Ast0.TestExprTag(e) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_typeC e)
- | Ast0.ParamTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_parameter e)
- | Ast0.InitTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_initialiser e)
- | Ast0.DeclTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_declaration e)
- | Ast0.StmtTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_statement e)
- | Ast0.CaseLineTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_case_line e)
- | Ast0.TopTag(e) ->
- (Ast0.get_index e,
- (collect_minus_join_points e).V0.combiner_top_level e)
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase")
- context_nodes
-
-(* result of collecting the join points should be sorted in nondecreasing
- order by line *)
-let verify l =
- let get_info = function
- (Favored,info,_) | (Unfavored,info,_) | (Toplevel,info,_)
- | (Decl,info,_) -> info in
- let token_start_line x = (get_info x).Ast0.logical_start in
- let token_end_line x = (get_info x).Ast0.logical_end in
- let token_real_start_line x = (get_info x).Ast0.line_start in
- let token_real_end_line x = (get_info x).Ast0.line_end in
- List.iter
- (function
- (index,((_::_) as l1)) ->
- let _ =
- List.fold_left
- (function (prev,real_prev) ->
- function cur ->
- let ln = token_start_line cur in
- if ln < prev
- then
- failwith
- (Printf.sprintf
- "error in collection of - tokens %d less than %d"
- (token_real_start_line cur) real_prev);
- (token_end_line cur,token_real_end_line cur))
- (token_end_line (List.hd l1), token_real_end_line (List.hd l1))
- (List.tl l1) in
- ()
- | _ -> ()) (* dots, in eg f() has no join points *)
- l
-
-let process_minus minus =
- create_root_token_table minus;
- List.concat
- (List.map
- (function x ->
- let res = call_collect_minus (collect_context x) in
- verify res;
- res)
- minus)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* collect the plus tokens *)
-
-let mk_structUnion x = Ast.StructUnionTag x
-let mk_sign x = Ast.SignTag x
-let mk_ident x = Ast.IdentTag (Ast0toast.ident x)
-let mk_expression x = Ast.ExpressionTag (Ast0toast.expression x)
-let mk_constant x = Ast.ConstantTag x
-let mk_unaryOp x = Ast.UnaryOpTag x
-let mk_assignOp x = Ast.AssignOpTag x
-let mk_fixOp x = Ast.FixOpTag x
-let mk_binaryOp x = Ast.BinaryOpTag x
-let mk_arithOp x = Ast.ArithOpTag x
-let mk_logicalOp x = Ast.LogicalOpTag x
-let mk_declaration x = Ast.DeclarationTag (Ast0toast.declaration x)
-let mk_topdeclaration x = Ast.DeclarationTag (Ast0toast.declaration x)
-let mk_storage x = Ast.StorageTag x
-let mk_inc_file x = Ast.IncFileTag x
-let mk_statement x = Ast.StatementTag (Ast0toast.statement x)
-let mk_case_line x = Ast.CaseLineTag (Ast0toast.case_line x)
-let mk_const_vol x = Ast.ConstVolTag x
-let mk_token x info = Ast.Token (x,Some info)
-let mk_meta (_,x) info = Ast.Token (x,Some info)
-let mk_code x = Ast.Code (Ast0toast.top_level x)
-
-let mk_exprdots x = Ast.ExprDotsTag (Ast0toast.expression_dots x)
-let mk_paramdots x = Ast.ParamDotsTag (Ast0toast.parameter_list x)
-let mk_stmtdots x = Ast.StmtDotsTag (Ast0toast.statement_dots x)
-let mk_decldots x = Ast.DeclDotsTag (Ast0toast.declaration_dots x)
-let mk_casedots x = failwith "+ case lines not supported"
-let mk_typeC x = Ast.FullTypeTag (Ast0toast.typeC x)
-let mk_init x = Ast.InitTag (Ast0toast.initialiser x)
-let mk_param x = Ast.ParamTag (Ast0toast.parameterTypeDef x)
-
-let collect_plus_nodes root =
- let root_index = Ast0.get_index root in
-
- let bind x y = x @ y in
- let option_default = [] in
-
- let mcode fn (term,_,info,mcodekind,_) =
- match mcodekind with Ast0.PLUS -> [(info,fn term)] | _ -> [] in
-
- let imcode fn (term,_,info,mcodekind,_) =
- match mcodekind with
- Ast0.PLUS -> [(info,fn term (Ast0toast.convert_info info))]
- | _ -> [] in
-
- let do_nothing fn r k e =
- match Ast0.get_mcodekind e with
- (Ast0.CONTEXT(_)) when not(Ast0.get_index e = root_index) -> []
- | Ast0.PLUS -> [(Ast0.get_info e,fn e)]
- | _ -> k e in
-
- (* case for everything that is just a wrapper for a simpler thing *)
- let stmt r k e =
- match Ast0.unwrap e with
- Ast0.Exp(exp) -> r.V0.combiner_expression exp
- | Ast0.TopExp(exp) -> r.V0.combiner_expression exp
- | Ast0.Ty(ty) -> r.V0.combiner_typeC ty
- | Ast0.TopInit(init) -> r.V0.combiner_initialiser init
- | Ast0.Decl(_,decl) -> r.V0.combiner_declaration decl
- | _ -> do_nothing mk_statement r k e in
-
- (* statementTag is preferred, because it indicates that one statement is
- replaced by one statement, in single_statement *)
- let stmt_dots r k e =
- match Ast0.unwrap e with
- Ast0.DOTS([s]) | Ast0.CIRCLES([s]) | Ast0.STARS([s]) ->
- r.V0.combiner_statement s
- | _ -> do_nothing mk_stmtdots r k e in
-
- let toplevel r k e =
- match Ast0.unwrap e with
- Ast0.DECL(s) -> r.V0.combiner_statement s
- | Ast0.CODE(sdots) -> r.V0.combiner_statement_dots sdots
- | _ -> do_nothing mk_code r k e in
-
- let initdots r k e = k e in
-
- V0.combiner bind option_default
- (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
- (mcode mk_fixOp)
- (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
- (mcode mk_sign) (mcode mk_structUnion)
- (mcode mk_storage) (mcode mk_inc_file)
- (do_nothing mk_exprdots) initdots
- (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
- (do_nothing mk_casedots)
- (do_nothing mk_ident) (do_nothing mk_expression)
- (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
- (do_nothing mk_declaration)
- stmt (do_nothing mk_case_line) toplevel
-
-let call_collect_plus context_nodes :
- (int * (Ast0.info * Ast.anything) list) list =
- List.map
- (function e ->
- match e with
- Ast0.DotsExprTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_expression_dots e)
- | Ast0.DotsInitTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_initialiser_list e)
- | Ast0.DotsParamTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_parameter_list e)
- | Ast0.DotsStmtTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_statement_dots e)
- | Ast0.DotsDeclTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_declaration_dots e)
- | Ast0.DotsCaseTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_case_line_dots e)
- | Ast0.IdentTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_ident e)
- | Ast0.ExprTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_expression e)
- | Ast0.ArgExprTag(_) | Ast0.TestExprTag(_) ->
- failwith "not possible - iso only"
- | Ast0.TypeCTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_typeC e)
- | Ast0.InitTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_initialiser e)
- | Ast0.ParamTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_parameter e)
- | Ast0.DeclTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_declaration e)
- | Ast0.StmtTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_statement e)
- | Ast0.CaseLineTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_case_line e)
- | Ast0.TopTag(e) ->
- (Ast0.get_index e,
- (collect_plus_nodes e).V0.combiner_top_level e)
- | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
- | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
- | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase")
- context_nodes
-
-(* The plus fragments are converted to a list of lists of lists.
-Innermost list: Elements have type anything. For any pair of successive
-elements, n and n+1, the ending line of n is the same as the starting line
-of n+1.
-Middle lists: For any pair of successive elements, n and n+1, the ending
-line of n is one less than the starting line of n+1.
-Outer list: For any pair of successive elements, n and n+1, the ending
-line of n is more than one less than the starting line of n+1. *)
-
-let logstart info = info.Ast0.logical_start
-let logend info = info.Ast0.logical_end
-
-let redo info start finish =
- {{info with Ast0.logical_start = start} with Ast0.logical_end = finish}
-
-let rec find_neighbors (index,l) :
- int * (Ast0.info * (Ast.anything list list)) list =
- let rec loop = function
- [] -> []
- | (i,x)::rest ->
- (match loop rest with
- ((i1,(x1::rest_inner))::rest_middle)::rest_outer ->
- let finish1 = logend i in
- let start2 = logstart i1 in
- if finish1 = start2
- then
- ((redo i (logstart i) (logend i1),(x::x1::rest_inner))
- ::rest_middle)
- ::rest_outer
- else if finish1 + 1 = start2
- then ((i,[x])::(i1,(x1::rest_inner))::rest_middle)::rest_outer
- else [(i,[x])]::((i1,(x1::rest_inner))::rest_middle)::rest_outer
- | _ -> [[(i,[x])]]) (* rest must be [] *) in
- let res =
- List.map
- (function l ->
- let (start_info,_) = List.hd l in
- let (end_info,_) = List.hd (List.rev l) in
- (redo start_info (logstart start_info) (logend end_info),
- List.map (function (_,x) -> x) l))
- (loop l) in
- (index,res)
-
-let process_plus plus :
- (int * (Ast0.info * Ast.anything list list) list) list =
- List.concat
- (List.map
- (function x ->
- List.map find_neighbors (call_collect_plus (collect_context x)))
- plus)
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* merge *)
-(*
-let merge_one = function
- (m1::m2::minus_info,p::plus_info) ->
- if p < m1, then
- attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
- if p > m1 && p < m2, then consider the following possibilities, in order
- m1 is Good and favored: attach to the beginning of m1.aft
- m2 is Good and favored: attach to the beginning of m2.bef; drop m1
- m1 is Good and unfavored: attach to the beginning of m1.aft
- m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
- also flip m1.bef if the first where > m1
- if we drop m1, then flip m1.aft first
- if p > m2
- m2 is Good and favored: attach to the beginning of m2.aft; drop m1
-*)
-
-(* end of first argument < start/end of second argument *)
-let less_than_start info1 info2 =
- info1.Ast0.logical_end < info2.Ast0.logical_start
-let less_than_end info1 info2 =
- info1.Ast0.logical_end < info2.Ast0.logical_end
-let greater_than_end info1 info2 =
- info1.Ast0.logical_start > info2.Ast0.logical_end
-let good_start info = info.Ast0.attachable_start
-let good_end info = info.Ast0.attachable_end
-
-let toplevel = function Toplevel -> true | Favored | Unfavored | Decl -> false
-let decl = function Decl -> true | Favored | Unfavored | Toplevel -> false
-let favored = function Favored -> true | Unfavored | Toplevel | Decl -> false
-
-let top_code =
- List.for_all (List.for_all (function Ast.Code _ -> true | _ -> false))
-
-(* The following is probably not correct. The idea is to detect what
-should be placed completely before the declaration. So type/storage
-related things do not fall into this category, and complete statements do
-fall into this category. But perhaps other things should be in this
-category as well, such as { or ;? *)
-let predecl_code =
- let tester = function
- (* the following should definitely be true *)
- Ast.DeclarationTag _
- | Ast.StatementTag _
- | Ast.Rule_elemTag _
- | Ast.StmtDotsTag _
- | Ast.Code _ -> true
- (* the following should definitely be false *)
- | Ast.FullTypeTag _ | Ast.BaseTypeTag _ | Ast.StructUnionTag _
- | Ast.SignTag _
- | Ast.StorageTag _ | Ast.ConstVolTag _ | Ast.TypeCTag _ -> false
- (* not sure about the rest *)
- | _ -> false in
- List.for_all (List.for_all tester)
-
-let pr = Printf.sprintf
-
-let insert thing thinginfo into intoinfo =
- let get_last l = let l = List.rev l in (List.rev(List.tl l),List.hd l) in
- let get_first l = (List.hd l,List.tl l) in
- let thing_start = thinginfo.Ast0.logical_start in
- let thing_end = thinginfo.Ast0.logical_end in
- let thing_offset = thinginfo.Ast0.offset in
- let into_start = intoinfo.Ast0.tline_start in
- let into_end = intoinfo.Ast0.tline_end in
- let into_left_offset = intoinfo.Ast0.left_offset in
- let into_right_offset = intoinfo.Ast0.right_offset in
- if thing_end < into_start && thing_start < into_start
- then (thing@into,
- {{intoinfo with Ast0.tline_start = thing_start}
- with Ast0.left_offset = thing_offset})
- else if thing_end = into_start && thing_offset < into_left_offset
- then
- let (prev,last) = get_last thing in
- let (first,rest) = get_first into in
- (prev@[last@first]@rest,
- {{intoinfo with Ast0.tline_start = thing_start}
- with Ast0.left_offset = thing_offset})
- else if thing_start > into_end && thing_end > into_end
- then (into@thing,
- {{intoinfo with Ast0.tline_end = thing_end}
- with Ast0.right_offset = thing_offset})
- else if thing_start = into_end && thing_offset > into_right_offset
- then
- let (first,rest) = get_first thing in
- let (prev,last) = get_last into in
- (prev@[last@first]@rest,
- {{intoinfo with Ast0.tline_end = thing_end}
- with Ast0.right_offset = thing_offset})
- else
- begin
- Printf.printf "thing start %d thing end %d into start %d into end %d\n"
- thing_start thing_end into_start into_end;
- Printf.printf "thing offset %d left offset %d right offset %d\n"
- thing_offset into_left_offset into_right_offset;
- Pretty_print_cocci.print_anything "" thing;
- Pretty_print_cocci.print_anything "" into;
- failwith "can't figure out where to put the + code"
- end
-
-let init thing info =
- (thing,
- {Ast0.tline_start = info.Ast0.logical_start;
- Ast0.tline_end = info.Ast0.logical_end;
- Ast0.left_offset = info.Ast0.offset;
- Ast0.right_offset = info.Ast0.offset})
-
-let attachbefore (infop,p) = function
- Ast0.MINUS(replacements) ->
- (match !replacements with
- ([],ti) -> replacements := init p infop
- | (repl,ti) -> replacements := insert p infop repl ti)
- | Ast0.CONTEXT(neighbors) ->
- let (repl,ti1,ti2) = !neighbors in
- (match repl with
- Ast.BEFORE(bef) ->
- let (bef,ti1) = insert p infop bef ti1 in
- neighbors := (Ast.BEFORE(bef),ti1,ti2)
- | Ast.AFTER(aft) ->
- let (bef,ti1) = init p infop in
- neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2)
- | Ast.BEFOREAFTER(bef,aft) ->
- let (bef,ti1) = insert p infop bef ti1 in
- neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2)
- | Ast.NOTHING ->
- let (bef,ti1) = init p infop in
- neighbors := (Ast.BEFORE(bef),ti1,ti2))
- | _ -> failwith "not possible for attachbefore"
-
-let attachafter (infop,p) = function
- Ast0.MINUS(replacements) ->
- (match !replacements with
- ([],ti) -> replacements := init p infop
- | (repl,ti) -> replacements := insert p infop repl ti)
- | Ast0.CONTEXT(neighbors) ->
- let (repl,ti1,ti2) = !neighbors in
- (match repl with
- Ast.BEFORE(bef) ->
- let (aft,ti2) = init p infop in
- neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2)
- | Ast.AFTER(aft) ->
- let (aft,ti2) = insert p infop aft ti2 in
- neighbors := (Ast.AFTER(aft),ti1,ti2)
- | Ast.BEFOREAFTER(bef,aft) ->
- let (aft,ti2) = insert p infop aft ti2 in
- neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2)
- | Ast.NOTHING ->
- let (aft,ti2) = init p infop in
- neighbors := (Ast.AFTER(aft),ti1,ti2))
- | _ -> failwith "not possible for attachbefore"
-
-let attach_all_before ps m =
- List.iter (function x -> attachbefore x m) ps
-
-let attach_all_after ps m =
- List.iter (function x -> attachafter x m) ps
-
-let split_at_end info ps =
- let split_point = info.Ast0.logical_end in
- List.partition
- (function (info,_) -> info.Ast0.logical_end < split_point)
- ps
-
-let allminus = function
- Ast0.MINUS(_) -> true
- | _ -> false
-
-let rec before_m1 ((f1,infom1,m1) as x1) ((f2,infom2,m2) as x2) rest = function
- [] -> ()
- | (((infop,_) as p) :: ps) as all ->
- if less_than_start infop infom1 or
- (allminus m1 && less_than_end infop infom1) (* account for trees *)
- then
- if good_start infom1
- then (attachbefore p m1; before_m1 x1 x2 rest ps)
- else
- failwith
- (pr "%d: no available token to attach to" infop.Ast0.line_start)
- else after_m1 x1 x2 rest all
-
-and after_m1 ((f1,infom1,m1) as x1) ((f2,infom2,m2) as x2) rest = function
- [] -> ()
- | (((infop,pcode) as p) :: ps) as all ->
- (* if the following is false, then some + code is stuck in the middle
- of some context code (m1). could drop down to the token level.
- this might require adjustments in ast0toast as well, when + code on
- expressions is dropped down to + code on expressions. it might
- also break some invariants on which iso depends, particularly on
- what it can infer from something being CONTEXT with no top-level
- modifications. for the moment, we thus give an error, asking the
- user to rewrite the semantic patch. *)
- if greater_than_end infop infom1 or is_minus m1 or !empty_isos
- then
- if less_than_start infop infom2
- then
- if predecl_code pcode && good_end infom1 && decl f1
- then (attachafter p m1; after_m1 x1 x2 rest ps)
- else if predecl_code pcode && good_start infom2 && decl f2
- then before_m2 x2 rest all
- else if top_code pcode && good_end infom1 && toplevel f1
- then (attachafter p m1; after_m1 x1 x2 rest ps)
- else if top_code pcode && good_start infom2 && toplevel f2
- then before_m2 x2 rest all
- else if good_end infom1 && favored f1
- then (attachafter p m1; after_m1 x1 x2 rest ps)
- else if good_start infom2 && favored f2
- then before_m2 x2 rest all
- else if good_end infom1
- then (attachafter p m1; after_m1 x1 x2 rest ps)
- else if good_start infom2
- then before_m2 x2 rest all
- else
- failwith
- (pr "%d: no available token to attach to" infop.Ast0.line_start)
- else after_m2 x2 rest all
- else
- begin
- Printf.printf "between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
- infop.Ast0.line_start infop.Ast0.line_end
- infom1.Ast0.line_start infom1.Ast0.line_end
- infom2.Ast0.line_start infom2.Ast0.line_end;
- Pretty_print_cocci.print_anything "" pcode;
- failwith
- "The semantic patch is structured in a way that may give bad results with isomorphisms. Please try to rewrite it by moving + code out from -/context terms."
- end
-
-(* not sure this is safe. if have iso problems, consider changing this
-to always return false *)
-and is_minus = function
- Ast0.MINUS _ -> true
- | _ -> false
-
-and before_m2 ((f2,infom2,m2) as x2) rest
- (p : (Ast0.info * Ast.anything list list) list) =
- match (rest,p) with
- (_,[]) -> ()
- | ([],((infop,_)::_)) ->
- let (bef_m2,aft_m2) = split_at_end infom2 p in (* bef_m2 isn't empty *)
- if good_start infom2
- then (attach_all_before bef_m2 m2; after_m2 x2 rest aft_m2)
- else
- failwith
- (pr "%d: no available token to attach to" infop.Ast0.line_start)
- | (m::ms,_) -> before_m1 x2 m ms p
-
-and after_m2 ((f2,infom2,m2) as x2) rest
- (p : (Ast0.info * Ast.anything list list) list) =
- match (rest,p) with
- (_,[]) -> ()
- | ([],((infop,_)::_)) ->
- if good_end infom2
- then attach_all_after p m2
- else
- failwith
- (pr "%d: no available token to attach to" infop.Ast0.line_start)
- | (m::ms,_) -> after_m1 x2 m ms p
-
-let merge_one : (minus_join_point * Ast0.info * 'a) list *
- (Ast0.info * Ast.anything list list) list -> unit = function (m,p) ->
- (*
- Printf.printf "minus code\n";
- List.iter
- (function (_,info,_) ->
- Printf.printf "start %d end %d real_start %d real_end %d\n"
- info.Ast0.logical_start info.Ast0.logical_end
- info.Ast0.line_start info.Ast0.line_end)
- m;
- Printf.printf "plus code\n";
- List.iter
- (function (info,p) ->
- Printf.printf "start %d end %d real_start %d real_end %d\n"
- info.Ast0.logical_start info.Ast0.logical_end
- info.Ast0.line_end info.Ast0.line_end;
- Pretty_print_cocci.print_anything "" p;
- Format.print_newline())
- p;
- *)
- match (m,p) with
- (_,[]) -> ()
- | (m1::m2::restm,p) -> before_m1 m1 m2 restm p
- | ([m],p) -> before_m2 m [] p
- | ([],_) -> failwith "minus tree ran out before the plus tree"
-
-let merge minus_list plus_list =
- (*
- Printf.printf "minus list %s\n"
- (String.concat " "
- (List.map (function (x,_) -> string_of_int x) minus_list));
- Printf.printf "plus list %s\n"
- (String.concat " "
- (List.map (function (x,_) -> string_of_int x) plus_list));
- *)
- List.iter
- (function (index,minus_info) ->
- let plus_info = List.assoc index plus_list in
- merge_one (minus_info,plus_info))
- minus_list
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Need to check that CONTEXT nodes have nothing attached to their tokens.
-If they do, they become MIXED *)
-
-let reevaluate_contextness =
- let bind = (@) in
- let option_default = [] in
-
- let mcode (_,_,_,mc,_) =
- match mc with
- Ast0.CONTEXT(mc) -> let (ba,_,_) = !mc in [ba]
- | _ -> [] in
-
- let donothing r k e =
- match Ast0.get_mcodekind e with
- Ast0.CONTEXT(mc) ->
- if List.exists (function Ast.NOTHING -> false | _ -> true) (k e)
- then Ast0.set_mcodekind e (Ast0.MIXED(mc));
- []
- | _ -> let _ = k e in [] in
-
- let res =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing donothing
- donothing
- donothing donothing donothing donothing donothing donothing donothing in
- res.V0.combiner_top_level
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-
-let insert_plus minus plus ei =
- empty_isos := ei;
- let minus_stream = process_minus minus in
- let plus_stream = process_plus plus in
- merge minus_stream plus_stream;
- List.iter (function x -> let _ = reevaluate_contextness x in ()) minus
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Potential problem: offset of mcode is not updated when an iso is
-instantiated, implying that a term may end up with many mcodes with the
-same offset. On the other hand, at the moment offset only seems to be used
-before this phase. Furthermore add_dot_binding relies on the offset to
-remain the same between matching an iso and instantiating it with bindings. *)
-
-(* --------------------------------------------------------------------- *)
-(* match a SmPL expression against a SmPL abstract syntax tree,
-either - or + *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module V0 = Visitor_ast0
-
-let current_rule = ref ""
-
-(* --------------------------------------------------------------------- *)
-
-type isomorphism =
- Ast_cocci.metavar list * Ast0_cocci.anything list list * string (* name *)
-
-let strip_info =
- let mcode (term,_,_,_,_) =
- (term,Ast0.NONE,Ast0.default_info(),Ast0.PLUS,ref Ast0.NoMetaPos) in
- let donothing r k e =
- let x = k e in
- {(Ast0.wrap (Ast0.unwrap x)) with
- Ast0.mcodekind = ref Ast0.PLUS;
- Ast0.true_if_test = x.Ast0.true_if_test} in
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing
-
-let anything_equal = function
- (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) ->
- failwith "not a possible variable binding" (*not sure why these are pbs*)
- | (Ast0.DotsInitTag(d1),Ast0.DotsInitTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) ->
- (strip_info.V0.rebuilder_statement_dots d1) =
- (strip_info.V0.rebuilder_statement_dots d2)
- | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.IdentTag(d1),Ast0.IdentTag(d2)) ->
- (strip_info.V0.rebuilder_ident d1) = (strip_info.V0.rebuilder_ident d2)
- | (Ast0.ExprTag(d1),Ast0.ExprTag(d2)) ->
- (strip_info.V0.rebuilder_expression d1) =
- (strip_info.V0.rebuilder_expression d2)
- | (Ast0.ArgExprTag(_),_) | (_,Ast0.ArgExprTag(_)) ->
- failwith "not possible - only in isos1"
- | (Ast0.TestExprTag(_),_) | (_,Ast0.TestExprTag(_)) ->
- failwith "not possible - only in isos1"
- | (Ast0.TypeCTag(d1),Ast0.TypeCTag(d2)) ->
- (strip_info.V0.rebuilder_typeC d1) =
- (strip_info.V0.rebuilder_typeC d2)
- | (Ast0.InitTag(d1),Ast0.InitTag(d2)) ->
- (strip_info.V0.rebuilder_initialiser d1) =
- (strip_info.V0.rebuilder_initialiser d2)
- | (Ast0.ParamTag(d1),Ast0.ParamTag(d2)) ->
- (strip_info.V0.rebuilder_parameter d1) =
- (strip_info.V0.rebuilder_parameter d2)
- | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) ->
- (strip_info.V0.rebuilder_declaration d1) =
- (strip_info.V0.rebuilder_declaration d2)
- | (Ast0.StmtTag(d1),Ast0.StmtTag(d2)) ->
- (strip_info.V0.rebuilder_statement d1) =
- (strip_info.V0.rebuilder_statement d2)
- | (Ast0.CaseLineTag(d1),Ast0.CaseLineTag(d2)) ->
- (strip_info.V0.rebuilder_case_line d1) =
- (strip_info.V0.rebuilder_case_line d2)
- | (Ast0.TopTag(d1),Ast0.TopTag(d2)) ->
- (strip_info.V0.rebuilder_top_level d1) =
- (strip_info.V0.rebuilder_top_level d2)
- | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_)) ->
- failwith "only for isos within iso phase"
- | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
- failwith "only for isos within iso phase"
- | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_)) ->
- failwith "only for isos within iso phase"
- | _ -> false
-
-let term (var1,_,_,_,_) = var1
-let dot_term (var1,_,info,_,_) = ("", var1 ^ (string_of_int info.Ast0.offset))
-
-
-type reason =
- NotPure of Ast0.pure * (string * string) * Ast0.anything
- | NotPureLength of (string * string)
- | ContextRequired of Ast0.anything
- | NonMatch
- | Braces of Ast0.statement
- | Position of string * string
- | TypeMatch of reason list
-
-let rec interpret_reason name line reason printer =
- Printf.printf
- "warning: iso %s does not match the code below on line %d\n" name line;
- printer(); Format.print_newline();
- match reason with
- NotPure(Ast0.Pure,(_,var),nonpure) ->
- Printf.printf
- "pure metavariable %s is matched against the following nonpure code:\n"
- var;
- Unparse_ast0.unparse_anything nonpure
- | NotPure(Ast0.Context,(_,var),nonpure) ->
- Printf.printf
- "context metavariable %s is matched against the following\nnoncontext code:\n"
- var;
- Unparse_ast0.unparse_anything nonpure
- | NotPure(Ast0.PureContext,(_,var),nonpure) ->
- Printf.printf
- "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
- var;
- Unparse_ast0.unparse_anything nonpure
- | NotPureLength((_,var)) ->
- Printf.printf
- "pure metavariable %s is matched against too much or too little code\n"
- var;
- | ContextRequired(term) ->
- Printf.printf
- "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
- Unparse_ast0.unparse_anything term
- | Braces(s) ->
- Printf.printf "braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
- Unparse_ast0.statement "" s;
- Format.print_newline()
- | Position(rule,name) ->
- Printf.printf "position variable %s.%s conflicts with an isomorphism\n"
- rule name;
- | TypeMatch reason_list ->
- List.iter (function r -> interpret_reason name line r printer)
- reason_list
- | _ -> failwith "not possible"
-
-type 'a either = OK of 'a | Fail of reason
-
-let add_binding var exp bindings =
- let var = term var in
- let attempt bindings =
- try
- let cur = List.assoc var bindings in
- if anything_equal(exp,cur) then [bindings] else []
- with Not_found -> [((var,exp)::bindings)] in
- match List.concat(List.map attempt bindings) with
- [] -> Fail NonMatch
- | x -> OK x
-
-let add_dot_binding var exp bindings =
- let var = dot_term var in
- let attempt bindings =
- try
- let cur = List.assoc var bindings in
- if anything_equal(exp,cur) then [bindings] else []
- with Not_found -> [((var,exp)::bindings)] in
- match List.concat(List.map attempt bindings) with
- [] -> Fail NonMatch
- | x -> OK x
-
-(* multi-valued *)
-let add_multi_dot_binding var exp bindings =
- let var = dot_term var in
- let attempt bindings = [((var,exp)::bindings)] in
- match List.concat(List.map attempt bindings) with
- [] -> Fail NonMatch
- | x -> OK x
-
-let rec nub ls =
- match ls with
- [] -> []
- | (x::xs) when (List.mem x xs) -> nub xs
- | (x::xs) -> x::(nub xs)
-
-(* --------------------------------------------------------------------- *)
-
-let init_env = [[]]
-
-let debug str m binding =
- let res = m binding in
- (match res with
- None -> Printf.printf "%s: failed\n" str
- | Some binding ->
- List.iter
- (function binding ->
- Printf.printf "%s: %s\n" str
- (String.concat " " (List.map (function (x,_) -> x) binding)))
- binding);
- res
-
-let conjunct_bindings
- (m1 : 'binding -> 'binding either)
- (m2 : 'binding -> 'binding either)
- (binding : 'binding) : 'binding either =
- match m1 binding with Fail(reason) -> Fail(reason) | OK binding -> m2 binding
-
-let rec conjunct_many_bindings = function
- [] -> failwith "not possible"
- | [x] -> x
- | x::xs -> conjunct_bindings x (conjunct_many_bindings xs)
-
-let mcode_equal (x,_,_,_,_) (y,_,_,_,_) = x = y
-
-let return b binding = if b then OK binding else Fail NonMatch
-let return_false reason binding = Fail reason
-
-let match_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> return true
- | _ -> return false
-
-let bool_match_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> true
- | _ -> false
-
-(* context_required is for the example
- if (
-+ (int * )
- x == NULL)
- where we can't change x == NULL to eg NULL == x. So there can either be
- nothing attached to the root or the term has to be all removed.
- if would be nice if we knew more about the relationship between the - and +
- code, because in the case where the + code is a separate statement in a
- sequence, this is not a problem. Perhaps something could be done in
- insert_plus
-
- The example seems strange. Why isn't the cast attached to x?
- *)
-let is_context e =
- !Flag.sgrep_mode2 or (* everything is context for sgrep *)
- (match Ast0.get_mcodekind e with
- Ast0.CONTEXT(cell) -> true
- | _ -> false)
-
-(* needs a special case when there is a Disj or an empty DOTS
- the following stops at the statement level, and gives true if one
- statement is replaced by another *)
-let rec is_pure_context s =
- !Flag.sgrep_mode2 or (* everything is context for sgrep *)
- (match Ast0.unwrap s with
- Ast0.Disj(starter,statement_dots_list,mids,ender) ->
- List.for_all
- (function x ->
- match Ast0.undots x with
- [s] -> is_pure_context s
- | _ -> false (* could we do better? *))
- statement_dots_list
- | _ ->
- (match Ast0.get_mcodekind s with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> true
- | _ -> false)
- | Ast0.MINUS(mc) ->
- (match !mc with
- (* do better for the common case of replacing a stmt by another one *)
- ([[Ast.StatementTag(s)]],_) ->
- (match Ast.unwrap s with
- Ast.IfThen(_,_,_) -> false (* potentially dangerous *)
- | _ -> true)
- | (_,_) -> false)
- | _ -> false))
-
-let is_minus e =
- match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
-
-let match_list matcher is_list_matcher do_list_match la lb =
- let rec loop = function
- ([],[]) -> return true
- | ([x],lb) when is_list_matcher x -> do_list_match x lb
- | (x::xs,y::ys) -> conjunct_bindings (matcher x y) (loop (xs,ys))
- | _ -> return false in
- loop (la,lb)
-
-let match_maker checks_needed context_required whencode_allowed =
-
- let check_mcode pmc cmc binding =
- if checks_needed
- then
- match Ast0.get_pos cmc with
- (Ast0.MetaPos (name,_,_)) as x ->
- (match Ast0.get_pos pmc with
- Ast0.MetaPos (name1,_,_) ->
- add_binding name1 (Ast0.MetaPosTag x) binding
- | Ast0.NoMetaPos ->
- let (rule,name) = Ast0.unwrap_mcode name in
- Fail (Position(rule,name)))
- | Ast0.NoMetaPos -> OK binding
- else OK binding in
-
- let match_dots matcher is_list_matcher do_list_match d1 d2 =
- match (Ast0.unwrap d1, Ast0.unwrap d2) with
- (Ast0.DOTS(la),Ast0.DOTS(lb))
- | (Ast0.CIRCLES(la),Ast0.CIRCLES(lb))
- | (Ast0.STARS(la),Ast0.STARS(lb)) ->
- match_list matcher is_list_matcher (do_list_match d2) la lb
- | _ -> return false in
-
- let is_elist_matcher el =
- match Ast0.unwrap el with Ast0.MetaExprList(_,_,_) -> true | _ -> false in
-
- let is_plist_matcher pl =
- match Ast0.unwrap pl with Ast0.MetaParamList(_,_,_) -> true | _ -> false in
-
- let is_slist_matcher pl =
- match Ast0.unwrap pl with Ast0.MetaStmtList(_,_) -> true | _ -> false in
-
- let no_list _ = false in
-
- let build_dots pattern data =
- match Ast0.unwrap pattern with
- Ast0.DOTS(_) -> Ast0.rewrap pattern (Ast0.DOTS(data))
- | Ast0.CIRCLES(_) -> Ast0.rewrap pattern (Ast0.CIRCLES(data))
- | Ast0.STARS(_) -> Ast0.rewrap pattern (Ast0.STARS(data)) in
-
- let pure_sp_code =
- let bind = Ast0.lub_pure in
- let option_default = Ast0.Context in
- let pure_mcodekind mc =
- if !Flag.sgrep_mode2
- then Ast0.PureContext
- else
- match mc with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> Ast0.PureContext
- | _ -> Ast0.Context)
- | Ast0.MINUS(mc) ->
- (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure)
- | _ -> Ast0.Impure in
- let donothing r k e =
- bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in
-
- let mcode m = pure_mcodekind (Ast0.get_mcode_mcodekind m) in
-
- (* a case for everything that has a metavariable *)
- (* pure is supposed to match only unitary metavars, not anything that
- contains only unitary metavars *)
- let ident r k i =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind i)) (k i))
- (match Ast0.unwrap i with
- Ast0.MetaId(name,_,pure) | Ast0.MetaFunc(name,_,pure)
- | Ast0.MetaLocalFunc(name,_,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let expression r k e =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e))
- (match Ast0.unwrap e with
- Ast0.MetaErr(name,_,pure)
- | Ast0.MetaExpr(name,_,_,_,pure) | Ast0.MetaExprList(name,_,pure) ->
- pure
- | _ -> Ast0.Impure) in
-
- let typeC r k t =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
- (match Ast0.unwrap t with
- Ast0.MetaType(name,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let param r k p =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind p)) (k p))
- (match Ast0.unwrap p with
- Ast0.MetaParam(name,pure) | Ast0.MetaParamList(name,_,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let stmt r k s =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind s)) (k s))
- (match Ast0.unwrap s with
- Ast0.MetaStmt(name,pure) | Ast0.MetaStmtList(name,pure) -> pure
- | _ -> Ast0.Impure) in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- ident expression typeC donothing param donothing stmt donothing
- donothing in
-
- let add_pure_list_binding name pure is_pure builder1 builder2 lst =
- match (checks_needed,pure) with
- (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
- (match lst with
- [x] ->
- if (Ast0.lub_pure (is_pure x) pure) = pure
- then add_binding name (builder1 lst)
- else return_false (NotPure (pure,term name,builder1 lst))
- | _ -> return_false (NotPureLength (term name)))
- | (false,_) | (_,Ast0.Impure) -> add_binding name (builder2 lst) in
-
- let add_pure_binding name pure is_pure builder x =
- match (checks_needed,pure) with
- (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
- if (Ast0.lub_pure (is_pure x) pure) = pure
- then add_binding name (builder x)
- else return_false (NotPure (pure,term name, builder x))
- | (false,_) | (_,Ast0.Impure) -> add_binding name (builder x) in
-
- let do_elist_match builder el lst =
- match Ast0.unwrap el with
- Ast0.MetaExprList(name,lenname,pure) ->
- (*how to handle lenname? should it be an option type and always None?*)
- failwith "expr list pattern not supported in iso"
- (*add_pure_list_binding name pure
- pure_sp_code.V0.combiner_expression
- (function lst -> Ast0.ExprTag(List.hd lst))
- (function lst -> Ast0.DotsExprTag(build_dots builder lst))
- lst*)
- | _ -> failwith "not possible" in
-
- let do_plist_match builder pl lst =
- match Ast0.unwrap pl with
- Ast0.MetaParamList(name,lename,pure) ->
- failwith "param list pattern not supported in iso"
- (*add_pure_list_binding name pure
- pure_sp_code.V0.combiner_parameter
- (function lst -> Ast0.ParamTag(List.hd lst))
- (function lst -> Ast0.DotsParamTag(build_dots builder lst))
- lst*)
- | _ -> failwith "not possible" in
-
- let do_slist_match builder sl lst =
- match Ast0.unwrap sl with
- Ast0.MetaStmtList(name,pure) ->
- add_pure_list_binding name pure
- pure_sp_code.V0.combiner_statement
- (function lst -> Ast0.StmtTag(List.hd lst))
- (function lst -> Ast0.DotsStmtTag(build_dots builder lst))
- lst
- | _ -> failwith "not possible" in
-
- let do_nolist_match _ _ = failwith "not possible" in
-
- let rec match_ident pattern id =
- match Ast0.unwrap pattern with
- Ast0.MetaId(name,_,pure) ->
- (add_pure_binding name pure pure_sp_code.V0.combiner_ident
- (function id -> Ast0.IdentTag id) id)
- | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
- | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context id
- then
- match (up,Ast0.unwrap id) with
- (Ast0.Id(namea),Ast0.Id(nameb)) ->
- if mcode_equal namea nameb
- then check_mcode namea nameb
- else return false
- | (Ast0.OptIdent(ida),Ast0.OptIdent(idb))
- | (Ast0.UniqueIdent(ida),Ast0.UniqueIdent(idb)) ->
- match_ident ida idb
- | (_,Ast0.OptIdent(idb))
- | (_,Ast0.UniqueIdent(idb)) -> match_ident pattern idb
- | _ -> return false
- else return_false (ContextRequired (Ast0.IdentTag id)) in
-
- (* should we do something about matching metavars against ...? *)
- let rec match_expr pattern expr =
- match Ast0.unwrap pattern with
- Ast0.MetaExpr(name,_,ty,form,pure) ->
- let form_ok =
- match (form,expr) with
- (Ast.ANY,_) -> true
- | (Ast.CONST,e) ->
- let rec matches e =
- match Ast0.unwrap e with
- Ast0.Constant(c) -> true
- | Ast0.Cast(lp,ty,rp,e) -> matches e
- | Ast0.SizeOfExpr(se,exp) -> true
- | Ast0.SizeOfType(se,lp,ty,rp) -> true
- | Ast0.MetaExpr(nm,_,_,Ast.CONST,p) ->
- (Ast0.lub_pure p pure) = pure
- | _ -> false in
- matches e
- | (Ast.ID,e) | (Ast.LocalID,e) ->
- let rec matches e =
- match Ast0.unwrap e with
- Ast0.Ident(c) -> true
- | Ast0.Cast(lp,ty,rp,e) -> matches e
- | Ast0.MetaExpr(nm,_,_,Ast.ID,p) ->
- (Ast0.lub_pure p pure) = pure
- | _ -> false in
- matches e in
- if form_ok
- then
- match ty with
- Some ts ->
- if List.exists
- (function Type_cocci.MetaType(_,_,_) -> true | _ -> false)
- ts
- then
- (match ts with
- [Type_cocci.MetaType(tyname,_,_)] ->
- let expty =
- match (Ast0.unwrap expr,Ast0.get_type expr) with
- (* easier than updating type inferencer to manage multiple
- types *)
- (Ast0.MetaExpr(_,_,Some tts,_,_),_) -> Some tts
- | (_,Some ty) -> Some [ty]
- | _ -> None in
- (match expty with
- Some expty ->
- let tyname = Ast0.rewrap_mcode name tyname in
- conjunct_bindings
- (add_pure_binding name pure
- pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr)
- (function bindings ->
- let attempts =
- List.map
- (function expty ->
- (try
- add_pure_binding tyname Ast0.Impure
- (function _ -> Ast0.Impure)
- (function ty -> Ast0.TypeCTag ty)
- (Ast0.rewrap expr
- (Ast0.reverse_type expty))
- bindings
- with Ast0.TyConv ->
- Printf.printf
- "warning: unconvertible type";
- return false bindings))
- expty in
- if List.exists
- (function Fail _ -> false | OK x -> true)
- attempts
- then
- (* not sure why this is ok. can there be more
- than one OK? *)
- OK (List.concat
- (List.map
- (function Fail _ -> [] | OK x -> x)
- attempts))
- else
- Fail
- (TypeMatch
- (List.map
- (function
- Fail r -> r
- | OK x -> failwith "not possible")
- attempts)))
- | _ ->
- (*Printf.printf
- "warning: type metavar can only match one type";*)
- return false)
- | _ ->
- failwith
- "mixture of metatype and other types not supported")
- else
- let expty = Ast0.get_type expr in
- if List.exists (function t -> Type_cocci.compatible t expty) ts
- then
- add_pure_binding name pure
- pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr
- else return false
- | None ->
- add_pure_binding name pure pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr
- else return false
- | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
- | Ast0.MetaExprList(_,_,_) -> failwith "metaexprlist not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context expr
- then
- match (up,Ast0.unwrap expr) with
- (Ast0.Ident(ida),Ast0.Ident(idb)) ->
- match_ident ida idb
- | (Ast0.Constant(consta),Ast0.Constant(constb)) ->
- if mcode_equal consta constb
- then check_mcode consta constb
- else return false
- | (Ast0.FunCall(fna,lp1,argsa,rp1),Ast0.FunCall(fnb,lp,argsb,rp)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp; match_expr fna fnb;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb]
- | (Ast0.Assignment(lefta,opa,righta,_),
- Ast0.Assignment(leftb,opb,rightb,_)) ->
- if mcode_equal opa opb
- then
- conjunct_many_bindings
- [check_mcode opa opb; match_expr lefta leftb;
- match_expr righta rightb]
- else return false
- | (Ast0.CondExpr(exp1a,lp1,exp2a,rp1,exp3a),
- Ast0.CondExpr(exp1b,lp,exp2b,rp,exp3b)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- match_expr exp1a exp1b; match_option match_expr exp2a exp2b;
- match_expr exp3a exp3b]
- | (Ast0.Postfix(expa,opa),Ast0.Postfix(expb,opb)) ->
- if mcode_equal opa opb
- then
- conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
- else return false
- | (Ast0.Infix(expa,opa),Ast0.Infix(expb,opb)) ->
- if mcode_equal opa opb
- then
- conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
- else return false
- | (Ast0.Unary(expa,opa),Ast0.Unary(expb,opb)) ->
- if mcode_equal opa opb
- then
- conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
- else return false
- | (Ast0.Binary(lefta,opa,righta),Ast0.Binary(leftb,opb,rightb)) ->
- if mcode_equal opa opb
- then
- conjunct_many_bindings
- [check_mcode opa opb; match_expr lefta leftb;
- match_expr righta rightb]
- else return false
- | (Ast0.Paren(lp1,expa,rp1),Ast0.Paren(lp,expb,rp)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp; match_expr expa expb]
- | (Ast0.ArrayAccess(exp1a,lb1,exp2a,rb1),
- Ast0.ArrayAccess(exp1b,lb,exp2b,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_expr exp1a exp1b; match_expr exp2a exp2b]
- | (Ast0.RecordAccess(expa,opa,fielda),
- Ast0.RecordAccess(expb,op,fieldb))
- | (Ast0.RecordPtAccess(expa,opa,fielda),
- Ast0.RecordPtAccess(expb,op,fieldb)) ->
- conjunct_many_bindings
- [check_mcode opa op; match_expr expa expb;
- match_ident fielda fieldb]
- | (Ast0.Cast(lp1,tya,rp1,expa),Ast0.Cast(lp,tyb,rp,expb)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- match_typeC tya tyb; match_expr expa expb]
- | (Ast0.SizeOfExpr(szf1,expa),Ast0.SizeOfExpr(szf,expb)) ->
- conjunct_bindings (check_mcode szf1 szf) (match_expr expa expb)
- | (Ast0.SizeOfType(szf1,lp1,tya,rp1),
- Ast0.SizeOfType(szf,lp,tyb,rp)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode szf1 szf; match_typeC tya tyb]
- | (Ast0.TypeExp(tya),Ast0.TypeExp(tyb)) ->
- match_typeC tya tyb
- | (Ast0.EComma(cm1),Ast0.EComma(cm)) -> check_mcode cm1 cm
- | (Ast0.DisjExpr(_,expsa,_,_),_) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.NestExpr(_,exp_dotsa,_,_,_),_) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.Edots(d,None),Ast0.Edots(d1,None))
- | (Ast0.Ecircles(d,None),Ast0.Ecircles(d1,None))
- | (Ast0.Estars(d,None),Ast0.Estars(d1,None)) -> check_mcode d d1
- | (Ast0.Edots(ed,None),Ast0.Edots(ed1,Some wc))
- | (Ast0.Ecircles(ed,None),Ast0.Ecircles(ed1,Some wc))
- | (Ast0.Estars(ed,None),Ast0.Estars(ed1,Some wc)) ->
- (* hope that mcode of edots is unique somehow *)
- conjunct_bindings (check_mcode ed ed1)
- (let (edots_whencode_allowed,_,_) = whencode_allowed in
- if edots_whencode_allowed
- then add_dot_binding ed (Ast0.ExprTag wc)
- else
- (Printf.printf
- "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Edots(_,Some _),_) | (Ast0.Ecircles(_,Some _),_)
- | (Ast0.Estars(_,Some _),_) ->
- failwith "whencode not allowed in a pattern1"
- | (Ast0.OptExp(expa),Ast0.OptExp(expb))
- | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) -> match_expr expa expb
- | (_,Ast0.OptExp(expb))
- | (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb
- | _ -> return false
- else return_false (ContextRequired (Ast0.ExprTag expr))
-
-(* the special case for function types prevents the eg T X; -> T X = E; iso
- from applying, which doesn't seem very relevant, but it also avoids a
- mysterious bug that is obtained with eg int attach(...); *)
- and match_typeC pattern t =
- match Ast0.unwrap pattern with
- Ast0.MetaType(name,pure) ->
- (match Ast0.unwrap t with
- Ast0.FunctionType(tya,lp1a,paramsa,rp1a) -> return false
- | _ ->
- add_pure_binding name pure pure_sp_code.V0.combiner_typeC
- (function ty -> Ast0.TypeCTag ty)
- t)
- | up ->
- if not(checks_needed) or not(context_required) or is_context t
- then
- match (up,Ast0.unwrap t) with
- (Ast0.ConstVol(cva,tya),Ast0.ConstVol(cvb,tyb)) ->
- if mcode_equal cva cvb
- then
- conjunct_bindings (check_mcode cva cvb) (match_typeC tya tyb)
- else return false
- | (Ast0.BaseType(tya,stringsa),Ast0.BaseType(tyb,stringsb)) ->
- if tya = tyb
- then
- match_list check_mcode
- (function _ -> false) (function _ -> failwith "")
- stringsa stringsb
- else return false
- | (Ast0.Signed(signa,tya),Ast0.Signed(signb,tyb)) ->
- if mcode_equal signa signb
- then
- conjunct_bindings (check_mcode signa signb)
- (match_option match_typeC tya tyb)
- else return false
- | (Ast0.Pointer(tya,star1),Ast0.Pointer(tyb,star)) ->
- conjunct_bindings (check_mcode star1 star) (match_typeC tya tyb)
- | (Ast0.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
- Ast0.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) ->
- conjunct_many_bindings
- [check_mcode stara starb; check_mcode lp1a lp1b;
- check_mcode rp1a rp1b; check_mcode lp2a lp2b;
- check_mcode rp2a rp2b; match_typeC tya tyb;
- match_dots match_param is_plist_matcher
- do_plist_match paramsa paramsb]
- | (Ast0.FunctionType(tya,lp1a,paramsa,rp1a),
- Ast0.FunctionType(tyb,lp1b,paramsb,rp1b)) ->
- conjunct_many_bindings
- [check_mcode lp1a lp1b; check_mcode rp1a rp1b;
- match_option match_typeC tya tyb;
- match_dots match_param is_plist_matcher do_plist_match
- paramsa paramsb]
- | (Ast0.Array(tya,lb1,sizea,rb1),Ast0.Array(tyb,lb,sizeb,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_typeC tya tyb; match_option match_expr sizea sizeb]
- | (Ast0.EnumName(kinda,namea),Ast0.EnumName(kindb,nameb)) ->
- conjunct_bindings (check_mcode kinda kindb)
- (match_ident namea nameb)
- | (Ast0.StructUnionName(kinda,Some namea),
- Ast0.StructUnionName(kindb,Some nameb)) ->
- if mcode_equal kinda kindb
- then
- conjunct_bindings (check_mcode kinda kindb)
- (match_ident namea nameb)
- else return false
- | (Ast0.StructUnionDef(tya,lb1,declsa,rb1),
- Ast0.StructUnionDef(tyb,lb,declsb,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_typeC tya tyb;
- match_dots match_decl no_list do_nolist_match declsa declsb]
- | (Ast0.TypeName(namea),Ast0.TypeName(nameb)) ->
- if mcode_equal namea nameb
- then check_mcode namea nameb
- else return false
- | (Ast0.DisjType(_,typesa,_,_),Ast0.DisjType(_,typesb,_,_)) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.OptType(tya),Ast0.OptType(tyb))
- | (Ast0.UniqueType(tya),Ast0.UniqueType(tyb)) -> match_typeC tya tyb
- | (_,Ast0.OptType(tyb))
- | (_,Ast0.UniqueType(tyb)) -> match_typeC pattern tyb
- | _ -> return false
- else return_false (ContextRequired (Ast0.TypeCTag t))
-
- and match_decl pattern d =
- if not(checks_needed) or not(context_required) or is_context d
- then
- match (Ast0.unwrap pattern,Ast0.unwrap d) with
- (Ast0.Init(stga,tya,ida,eq1,inia,sc1),
- Ast0.Init(stgb,tyb,idb,eq,inib,sc)) ->
- if bool_match_option mcode_equal stga stgb
- then
- conjunct_many_bindings
- [check_mcode eq1 eq; check_mcode sc1 sc;
- match_option check_mcode stga stgb;
- match_typeC tya tyb; match_ident ida idb;
- match_init inia inib]
- else return false
- | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) ->
- if bool_match_option mcode_equal stga stgb
- then
- conjunct_many_bindings
- [check_mcode sc1 sc; match_option check_mcode stga stgb;
- match_typeC tya tyb; match_ident ida idb]
- else return false
- | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1),
- Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) ->
- conjunct_many_bindings
- [match_ident namea nameb;
- check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode sc1 sc;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb]
- | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb)
- | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc)
- (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb))
- | (Ast0.DisjDecl(_,declsa,_,_),Ast0.DisjDecl(_,declsb,_,_)) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d
- | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) ->
- conjunct_bindings (check_mcode dd d)
- (* hope that mcode of ddots is unique somehow *)
- (let (ddots_whencode_allowed,_,_) = whencode_allowed in
- if ddots_whencode_allowed
- then add_dot_binding dd (Ast0.DeclTag wc)
- else
- (Printf.printf "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Ddots(_,Some _),_) ->
- failwith "whencode not allowed in a pattern1"
-
- | (Ast0.OptDecl(decla),Ast0.OptDecl(declb))
- | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) ->
- match_decl decla declb
- | (_,Ast0.OptDecl(declb))
- | (_,Ast0.UniqueDecl(declb)) ->
- match_decl pattern declb
- | _ -> return false
- else return_false (ContextRequired (Ast0.DeclTag d))
-
- and match_init pattern i =
- if not(checks_needed) or not(context_required) or is_context i
- then
- match (Ast0.unwrap pattern,Ast0.unwrap i) with
- (Ast0.InitExpr(expa),Ast0.InitExpr(expb)) ->
- match_expr expa expb
- | (Ast0.InitList(lb1,initlista,rb1),Ast0.InitList(lb,initlistb,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_dots match_init no_list do_nolist_match
- initlista initlistb]
- | (Ast0.InitGccDotName(d1,namea,e1,inia),
- Ast0.InitGccDotName(d,nameb,e,inib)) ->
- conjunct_many_bindings
- [check_mcode d1 d; check_mcode e1 e;
- match_ident namea nameb; match_init inia inib]
- | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) ->
- conjunct_many_bindings
- [check_mcode c1 c; match_ident namea nameb;
- match_init inia inib]
- | (Ast0.InitGccIndex(lb1,expa,rb1,e1,inia),
- Ast0.InitGccIndex(lb2,expb,rb2,e2,inib)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb2; check_mcode rb1 rb2; check_mcode e1 e2;
- match_expr expa expb; match_init inia inib]
- | (Ast0.InitGccRange(lb1,exp1a,d1,exp2a,rb1,e1,inia),
- Ast0.InitGccRange(lb2,exp1b,d2,exp2b,rb2,e2,inib)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb2; check_mcode d1 d2;
- check_mcode rb1 rb2; check_mcode e1 e2;
- match_expr exp1a exp1b; match_expr exp2a exp2b;
- match_init inia inib]
- | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c
- | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d
- | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) ->
- conjunct_bindings (check_mcode id d)
- (* hope that mcode of edots is unique somehow *)
- (let (_,idots_whencode_allowed,_) = whencode_allowed in
- if idots_whencode_allowed
- then add_dot_binding id (Ast0.InitTag wc)
- else
- (Printf.printf "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Idots(_,Some _),_) ->
- failwith "whencode not allowed in a pattern2"
- | (Ast0.OptIni(ia),Ast0.OptIni(ib))
- | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib
- | (_,Ast0.OptIni(ib))
- | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib
- | _ -> return false
- else return_false (ContextRequired (Ast0.InitTag i))
-
- and match_param pattern p =
- match Ast0.unwrap pattern with
- Ast0.MetaParam(name,pure) ->
- add_pure_binding name pure pure_sp_code.V0.combiner_parameter
- (function p -> Ast0.ParamTag p)
- p
- | Ast0.MetaParamList(name,_,pure) -> failwith "metaparamlist not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context p
- then
- match (up,Ast0.unwrap p) with
- (Ast0.VoidParam(tya),Ast0.VoidParam(tyb)) -> match_typeC tya tyb
- | (Ast0.Param(tya,ida),Ast0.Param(tyb,idb)) ->
- conjunct_bindings (match_typeC tya tyb)
- (match_option match_ident ida idb)
- | (Ast0.PComma(c1),Ast0.PComma(c)) -> check_mcode c1 c
- | (Ast0.Pdots(d1),Ast0.Pdots(d))
- | (Ast0.Pcircles(d1),Ast0.Pcircles(d)) -> check_mcode d1 d
- | (Ast0.OptParam(parama),Ast0.OptParam(paramb))
- | (Ast0.UniqueParam(parama),Ast0.UniqueParam(paramb)) ->
- match_param parama paramb
- | (_,Ast0.OptParam(paramb))
- | (_,Ast0.UniqueParam(paramb)) -> match_param pattern paramb
- | _ -> return false
- else return_false (ContextRequired (Ast0.ParamTag p))
-
- and match_statement pattern s =
- match Ast0.unwrap pattern with
- Ast0.MetaStmt(name,pure) ->
- (match Ast0.unwrap s with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) ->
- return false (* ... is not a single statement *)
- | _ ->
- add_pure_binding name pure pure_sp_code.V0.combiner_statement
- (function ty -> Ast0.StmtTag ty)
- s)
- | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context s
- then
- match (up,Ast0.unwrap s) with
- (Ast0.FunDecl(_,fninfoa,namea,lp1,paramsa,rp1,lb1,bodya,rb1),
- Ast0.FunDecl(_,fninfob,nameb,lp,paramsb,rp,lb,bodyb,rb)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode lb1 lb; check_mcode rb1 rb;
- match_fninfo fninfoa fninfob; match_ident namea nameb;
- match_dots match_param is_plist_matcher do_plist_match
- paramsa paramsb;
- match_dots match_statement is_slist_matcher do_slist_match
- bodya bodyb]
- | (Ast0.Decl(_,decla),Ast0.Decl(_,declb)) ->
- match_decl decla declb
- | (Ast0.Seq(lb1,bodya,rb1),Ast0.Seq(lb,bodyb,rb)) ->
- (* seqs can only match if they are all minus (plus code
- allowed) or all context (plus code not allowed in the body).
- we could be more permissive if the expansions of the isos are
- also all seqs, but this would be hard to check except at top
- level, and perhaps not worth checking even in that case.
- Overall, the issue is that braces are used where single
- statements are required, and something not satisfying these
- conditions can cause a single statement to become a
- non-single statement after the transformation.
-
- example: if { ... -foo(); ... }
- if we let the sequence convert to just -foo();
- then we produce invalid code. For some reason,
- single_statement can't deal with this case, perhaps because
- it starts introducing too many braces? don't remember the
- exact problem...
- *)
- conjunct_bindings (check_mcode lb1 lb)
- (conjunct_bindings (check_mcode rb1 rb)
- (if not(checks_needed) or is_minus s or
- (is_context s &&
- List.for_all is_pure_context (Ast0.undots bodyb))
- then
- match_dots match_statement is_slist_matcher do_slist_match
- bodya bodyb
- else return_false (Braces(s))))
- | (Ast0.ExprStatement(expa,sc1),Ast0.ExprStatement(expb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc) (match_expr expa expb)
- | (Ast0.IfThen(if1,lp1,expa,rp1,branch1a,_),
- Ast0.IfThen(if2,lp2,expb,rp2,branch1b,_)) ->
- conjunct_many_bindings
- [check_mcode if1 if2; check_mcode lp1 lp2;
- check_mcode rp1 rp2;
- match_expr expa expb;
- match_statement branch1a branch1b]
- | (Ast0.IfThenElse(if1,lp1,expa,rp1,branch1a,e1,branch2a,_),
- Ast0.IfThenElse(if2,lp2,expb,rp2,branch1b,e2,branch2b,_)) ->
- conjunct_many_bindings
- [check_mcode if1 if2; check_mcode lp1 lp2;
- check_mcode rp1 rp2; check_mcode e1 e2;
- match_expr expa expb;
- match_statement branch1a branch1b;
- match_statement branch2a branch2b]
- | (Ast0.While(w1,lp1,expa,rp1,bodya,_),
- Ast0.While(w,lp,expb,rp,bodyb,_)) ->
- conjunct_many_bindings
- [check_mcode w1 w; check_mcode lp1 lp;
- check_mcode rp1 rp; match_expr expa expb;
- match_statement bodya bodyb]
- | (Ast0.Do(d1,bodya,w1,lp1,expa,rp1,_),
- Ast0.Do(d,bodyb,w,lp,expb,rp,_)) ->
- conjunct_many_bindings
- [check_mcode d1 d; check_mcode w1 w; check_mcode lp1 lp;
- check_mcode rp1 rp; match_statement bodya bodyb;
- match_expr expa expb]
- | (Ast0.For(f1,lp1,e1a,sc1a,e2a,sc2a,e3a,rp1,bodya,_),
- Ast0.For(f,lp,e1b,sc1b,e2b,sc2b,e3b,rp,bodyb,_)) ->
- conjunct_many_bindings
- [check_mcode f1 f; check_mcode lp1 lp; check_mcode sc1a sc1b;
- check_mcode sc2a sc2b; check_mcode rp1 rp;
- match_option match_expr e1a e1b;
- match_option match_expr e2a e2b;
- match_option match_expr e3a e3b;
- match_statement bodya bodyb]
- | (Ast0.Iterator(nma,lp1,argsa,rp1,bodya,_),
- Ast0.Iterator(nmb,lp,argsb,rp,bodyb,_)) ->
- conjunct_many_bindings
- [match_ident nma nmb;
- check_mcode lp1 lp; check_mcode rp1 rp;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb;
- match_statement bodya bodyb]
- | (Ast0.Switch(s1,lp1,expa,rp1,lb1,casesa,rb1),
- Ast0.Switch(s,lp,expb,rp,lb,casesb,rb)) ->
- conjunct_many_bindings
- [check_mcode s1 s; check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode lb1 lb; check_mcode rb1 rb;
- match_expr expa expb;
- match_dots match_case_line no_list do_nolist_match
- casesa casesb]
- | (Ast0.Break(b1,sc1),Ast0.Break(b,sc))
- | (Ast0.Continue(b1,sc1),Ast0.Continue(b,sc)) ->
- conjunct_bindings (check_mcode b1 b) (check_mcode sc1 sc)
- | (Ast0.Label(l1,c1),Ast0.Label(l2,c)) ->
- conjunct_bindings (match_ident l1 l2) (check_mcode c1 c)
- | (Ast0.Goto(g1,l1,sc1),Ast0.Goto(g,l2,sc)) ->
- conjunct_many_bindings
- [check_mcode g1 g; check_mcode sc1 sc; match_ident l1 l2]
- | (Ast0.Return(r1,sc1),Ast0.Return(r,sc)) ->
- conjunct_bindings (check_mcode r1 r) (check_mcode sc1 sc)
- | (Ast0.ReturnExpr(r1,expa,sc1),Ast0.ReturnExpr(r,expb,sc)) ->
- conjunct_many_bindings
- [check_mcode r1 r; check_mcode sc1 sc; match_expr expa expb]
- | (Ast0.Disj(_,statement_dots_lista,_,_),_) ->
- failwith "disj not supported in patterns"
- | (Ast0.Nest(_,stmt_dotsa,_,_,_),_) ->
- failwith "nest not supported in patterns"
- | (Ast0.Exp(expa),Ast0.Exp(expb)) -> match_expr expa expb
- | (Ast0.TopExp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
- | (Ast0.Exp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
- | (Ast0.TopInit(inita),Ast0.TopInit(initb)) -> match_init inita initb
- | (Ast0.Ty(tya),Ast0.Ty(tyb)) -> match_typeC tya tyb
- | (Ast0.Dots(d,[]),Ast0.Dots(d1,wc))
- | (Ast0.Circles(d,[]),Ast0.Circles(d1,wc))
- | (Ast0.Stars(d,[]),Ast0.Stars(d1,wc)) ->
- (match wc with
- [] -> check_mcode d d1
- | _ ->
- let (_,_,dots_whencode_allowed) = whencode_allowed in
- if dots_whencode_allowed
- then
- conjunct_bindings (check_mcode d d1)
- (List.fold_left
- (function prev ->
- function
- | Ast0.WhenNot wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.DotsStmtTag wc))
- | Ast0.WhenAlways wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d (Ast0.StmtTag wc))
- | Ast0.WhenNotTrue wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.IsoWhenTTag wc))
- | Ast0.WhenNotFalse wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.IsoWhenFTag wc))
- | Ast0.WhenModifier(x) ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.IsoWhenTag x)))
- (return true) wc)
- else
- (Printf.printf
- "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Dots(_,_::_),_) | (Ast0.Circles(_,_::_),_)
- | (Ast0.Stars(_,_::_),_) ->
- failwith "whencode not allowed in a pattern3"
- | (Ast0.OptStm(rea),Ast0.OptStm(reb))
- | (Ast0.UniqueStm(rea),Ast0.UniqueStm(reb)) ->
- match_statement rea reb
- | (_,Ast0.OptStm(reb))
- | (_,Ast0.UniqueStm(reb)) -> match_statement pattern reb
- | _ -> return false
- else return_false (ContextRequired (Ast0.StmtTag s))
-
- (* first should provide a subset of the information in the second *)
- and match_fninfo patterninfo cinfo =
- let patterninfo = List.sort compare patterninfo in
- let cinfo = List.sort compare cinfo in
- let rec loop = function
- (Ast0.FStorage(sta)::resta,Ast0.FStorage(stb)::restb) ->
- if mcode_equal sta stb
- then conjunct_bindings (check_mcode sta stb) (loop (resta,restb))
- else return false
- | (Ast0.FType(tya)::resta,Ast0.FType(tyb)::restb) ->
- conjunct_bindings (match_typeC tya tyb) (loop (resta,restb))
- | (Ast0.FInline(ia)::resta,Ast0.FInline(ib)::restb) ->
- if mcode_equal ia ib
- then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
- else return false
- | (Ast0.FAttr(ia)::resta,Ast0.FAttr(ib)::restb) ->
- if mcode_equal ia ib
- then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
- else return false
- | (x::resta,((y::_) as restb)) ->
- (match compare x y with
- -1 -> return false
- | 1 -> loop (resta,restb)
- | _ -> failwith "not possible")
- | _ -> return false in
- loop (patterninfo,cinfo)
-
- and match_case_line pattern c =
- if not(checks_needed) or not(context_required) or is_context c
- then
- match (Ast0.unwrap pattern,Ast0.unwrap c) with
- (Ast0.Default(d1,c1,codea),Ast0.Default(d,c,codeb)) ->
- conjunct_many_bindings
- [check_mcode d1 d; check_mcode c1 c;
- match_dots match_statement is_slist_matcher do_slist_match
- codea codeb]
- | (Ast0.Case(ca1,expa,c1,codea),Ast0.Case(ca,expb,c,codeb)) ->
- conjunct_many_bindings
- [check_mcode ca1 ca; check_mcode c1 c; match_expr expa expb;
- match_dots match_statement is_slist_matcher do_slist_match
- codea codeb]
- | (Ast0.OptCase(ca),Ast0.OptCase(cb)) -> match_case_line ca cb
- | (_,Ast0.OptCase(cb)) -> match_case_line pattern cb
- | _ -> return false
- else return_false (ContextRequired (Ast0.CaseLineTag c)) in
-
- let match_statement_dots x y =
- match_dots match_statement is_slist_matcher do_slist_match x y in
-
- (match_expr, match_decl, match_statement, match_typeC,
- match_statement_dots)
-
-let match_expr dochecks context_required whencode_allowed =
- let (fn,_,_,_,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_decl dochecks context_required whencode_allowed =
- let (_,fn,_,_,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_statement dochecks context_required whencode_allowed =
- let (_,_,fn,_,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_typeC dochecks context_required whencode_allowed =
- let (_,_,_,fn,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_statement_dots dochecks context_required whencode_allowed =
- let (_,_,_,_,fn) = match_maker dochecks context_required whencode_allowed in
- fn
-
-(* --------------------------------------------------------------------- *)
-(* make an entire tree MINUS *)
-
-let make_minus =
- let mcode (term,arity,info,mcodekind,pos) =
- let new_mcodekind =
- match mcodekind with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> Ast0.MINUS(ref([],Ast0.default_token_info))
- | _ -> failwith "make_minus: unexpected befaft")
- | Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *)
- | _ -> failwith "make_minus mcode: unexpected mcodekind" in
- (term,arity,info,new_mcodekind,pos) in
-
- let update_mc mcodekind e =
- match !mcodekind with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) ->
- mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info))
- | _ -> failwith "make_minus: unexpected befaft")
- | Ast0.MINUS(_mc) -> () (* in the part copied from the src term *)
- | Ast0.PLUS -> failwith "make_minus donothing: unexpected plus mcodekind"
- | _ -> failwith "make_minus donothing: unexpected mcodekind" in
-
- let donothing r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- let e = k e in update_mc mcodekind e; e in
-
- (* special case for whencode, because it isn't processed by contextneg,
- since it doesn't appear in the + code *)
- (* cases for dots and nests *)
- let expression r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Edots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Edots(mcode d,whencode))
- | Ast0.Ecircles(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Ecircles(mcode d,whencode))
- | Ast0.Estars(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Estars(mcode d,whencode))
- | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
- update_mc mcodekind e;
- Ast0.rewrap e
- (Ast0.NestExpr(mcode starter,
- r.V0.rebuilder_expression_dots expr_dots,
- mcode ender,whencode,multi))
- | _ -> donothing r k e in
-
- let declaration r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Ddots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Ddots(mcode d,whencode))
- | _ -> donothing r k e in
-
- let statement r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Dots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Dots(mcode d,whencode))
- | Ast0.Circles(d,whencode) ->
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Circles(mcode d,whencode))
- | Ast0.Stars(d,whencode) ->
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Stars(mcode d,whencode))
- | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) ->
- update_mc mcodekind e;
- Ast0.rewrap e
- (Ast0.Nest(mcode starter,r.V0.rebuilder_statement_dots stmt_dots,
- mcode ender,whencode,multi))
- | _ -> donothing r k e in
-
- let initialiser r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Idots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Idots(mcode d,whencode))
- | _ -> donothing r k e in
-
- let dots r k e =
- let info = Ast0.get_info e in
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.DOTS([]) ->
- (* if context is - this should be - as well. There are no tokens
- here though, so the bottom-up minusifier in context_neg leaves it
- as mixed (or context for sgrep2). It would be better to fix
- context_neg, but that would
- require a special case for each term with a dots subterm. *)
- (match !mcodekind with
- Ast0.MIXED(mc) | Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) ->
- mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info));
- e
- | _ -> failwith "make_minus: unexpected befaft")
- (* code already processed by an enclosing iso *)
- | Ast0.MINUS(mc) -> e
- | _ ->
- failwith
- (Printf.sprintf
- "%d: make_minus donothingxxx: unexpected mcodekind: %s"
- info.Ast0.line_start (Dumper.dump e)))
- | _ -> donothing r k e in
-
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- dots dots dots dots dots dots
- donothing expression donothing initialiser donothing declaration
- statement donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* rebuild mcode cells in an instantiated alt *)
-
-(* mcodes will be side effected later with plus code, so we have to copy
- them on instantiating an isomorphism. One could wonder whether it would
- be better not to use side-effects, but they are convenient for insert_plus
- where is it useful to manipulate a list of the mcodes but side-effect a
- tree *)
-(* hmm... Insert_plus is called before Iso_pattern... *)
-let rebuild_mcode start_line =
- let copy_mcodekind = function
- Ast0.CONTEXT(mc) -> Ast0.CONTEXT(ref (!mc))
- | Ast0.MINUS(mc) -> Ast0.MINUS(ref (!mc))
- | Ast0.MIXED(mc) -> Ast0.MIXED(ref (!mc))
- | Ast0.PLUS ->
- (* this function is used elsewhere where we need to rebuild the
- indices, and so we allow PLUS code as well *)
- Ast0.PLUS in
-
- let mcode (term,arity,info,mcodekind,pos) =
- let info =
- match start_line with
- Some x -> {info with Ast0.line_start = x; Ast0.line_end = x}
- | None -> info in
- (term,arity,info,copy_mcodekind mcodekind,pos) in
-
- let copy_one x =
- let old_info = Ast0.get_info x in
- let info =
- match start_line with
- Some x -> {old_info with Ast0.line_start = x; Ast0.line_end = x}
- | None -> old_info in
- {x with Ast0.info = info; Ast0.index = ref(Ast0.get_index x);
- Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind x))} in
-
- let donothing r k e = copy_one (k e) in
-
- (* case for control operators (if, etc) *)
- let statement r k e =
- let s = k e in
- let res =
- copy_one
- (Ast0.rewrap s
- (match Ast0.unwrap s with
- Ast0.Decl((info,mc),decl) ->
- Ast0.Decl((info,copy_mcodekind mc),decl)
- | Ast0.IfThen(iff,lp,tst,rp,branch,(info,mc)) ->
- Ast0.IfThen(iff,lp,tst,rp,branch,(info,copy_mcodekind mc))
- | Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,(info,mc)) ->
- Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,
- (info,copy_mcodekind mc))
- | Ast0.While(whl,lp,exp,rp,body,(info,mc)) ->
- Ast0.While(whl,lp,exp,rp,body,(info,copy_mcodekind mc))
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,(info,mc)) ->
- Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,
- (info,copy_mcodekind mc))
- | Ast0.Iterator(nm,lp,args,rp,body,(info,mc)) ->
- Ast0.Iterator(nm,lp,args,rp,body,(info,copy_mcodekind mc))
- | Ast0.FunDecl
- ((info,mc),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- Ast0.FunDecl
- ((info,copy_mcodekind mc),
- fninfo,name,lp,params,rp,lbrace,body,rbrace)
- | s -> s)) in
- Ast0.set_dots_bef_aft res
- (match Ast0.get_dots_bef_aft res with
- Ast0.NoDots -> Ast0.NoDots
- | Ast0.AddingBetweenDots s ->
- Ast0.AddingBetweenDots(r.V0.rebuilder_statement s)
- | Ast0.DroppingBetweenDots s ->
- Ast0.DroppingBetweenDots(r.V0.rebuilder_statement s)) in
-
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing
- donothing statement donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* The problem of whencode. If an isomorphism contains dots in multiple
- rules, then the code that is matched cannot contain whencode, because we
- won't know which dots it goes with. Should worry about nests, but they
- aren't allowed in isomorphisms for the moment. *)
-
-let count_edots =
- let mcode x = 0 in
- let option_default = 0 in
- let bind x y = x + y in
- let donothing r k e = k e in
- let exprfn r k e =
- match Ast0.unwrap e with
- Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> 1
- | _ -> 0 in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing exprfn donothing donothing donothing donothing donothing
- donothing donothing
-
-let count_idots =
- let mcode x = 0 in
- let option_default = 0 in
- let bind x y = x + y in
- let donothing r k e = k e in
- let initfn r k e =
- match Ast0.unwrap e with Ast0.Idots(_,_) -> 1 | _ -> 0 in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing initfn donothing donothing donothing
- donothing donothing
-
-let count_dots =
- let mcode x = 0 in
- let option_default = 0 in
- let bind x y = x + y in
- let donothing r k e = k e in
- let stmtfn r k e =
- match Ast0.unwrap e with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> 1
- | _ -> 0 in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing stmtfn
- donothing donothing
-
-(* --------------------------------------------------------------------- *)
-
-let lookup name bindings mv_bindings =
- try Common.Left (List.assoc (term name) bindings)
- with
- Not_found ->
- (* failure is not possible anymore *)
- Common.Right (List.assoc (term name) mv_bindings)
-
-(* mv_bindings is for the fresh metavariables that are introduced by the
-isomorphism *)
-let instantiate bindings mv_bindings =
- let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,_,_) ->
- (try
- match lookup name bindings mv_bindings with
- Common.Left(Ast0.MetaPosTag(id)) -> Ast0.set_pos id x
- | _ -> failwith "not possible"
- with Not_found -> Ast0.set_pos Ast0.NoMetaPos x)
- | _ -> x in
- let donothing r k e = k e in
-
- (* cases where metavariables can occur *)
- let identfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaId(name,constraints,pure) ->
- (rebuild_mcode None).V0.rebuilder_ident
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.IdentTag(id)) -> id
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaId
- (Ast0.set_mcode_data new_mv name,constraints,pure)))
- | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
- | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
- | _ -> e in
-
- (* case for list metavariables *)
- let rec elist r same_dots = function
- [] -> []
- | [x] ->
- (match Ast0.unwrap x with
- Ast0.MetaExprList(name,lenname,pure) ->
- failwith "meta_expr_list in iso not supported"
- (*match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsExprTag(exp)) ->
- (match same_dots exp with
- Some l -> l
- | None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.ExprTag(exp)) -> [exp]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- failwith "MetaExprList in SP not supported"*)
- | _ -> [r.V0.rebuilder_expression x])
- | x::xs -> (r.V0.rebuilder_expression x)::(elist r same_dots xs) in
-
- let rec plist r same_dots = function
- [] -> []
- | [x] ->
- (match Ast0.unwrap x with
- Ast0.MetaParamList(name,lenname,pure) ->
- failwith "meta_param_list in iso not supported"
- (*match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsParamTag(param)) ->
- (match same_dots param with
- Some l -> l
- | None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.ParamTag(param)) -> [param]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- failwith "MetaExprList in SP not supported"*)
- | _ -> [r.V0.rebuilder_parameter x])
- | x::xs -> (r.V0.rebuilder_parameter x)::(plist r same_dots xs) in
-
- let rec slist r same_dots = function
- [] -> []
- | [x] ->
- (match Ast0.unwrap x with
- Ast0.MetaStmtList(name,pure) ->
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsStmtTag(stm)) ->
- (match same_dots stm with
- Some l -> l
- | None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.StmtTag(stm)) -> [stm]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- failwith "MetaExprList in SP not supported")
- | _ -> [r.V0.rebuilder_statement x])
- | x::xs -> (r.V0.rebuilder_statement x)::(slist r same_dots xs) in
-
- let same_dots d =
- match Ast0.unwrap d with Ast0.DOTS(l) -> Some l |_ -> None in
- let same_circles d =
- match Ast0.unwrap d with Ast0.CIRCLES(l) -> Some l |_ -> None in
- let same_stars d =
- match Ast0.unwrap d with Ast0.STARS(l) -> Some l |_ -> None in
-
- let dots list_fn r k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(list_fn r same_dots l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(list_fn r same_circles l)
- | Ast0.STARS(l) -> Ast0.STARS(list_fn r same_stars l)) in
-
- let exprfn r k old_e = (* need to keep the original code for ! optim *)
- let e = k old_e in
- let e1 =
- match Ast0.unwrap e with
- Ast0.MetaExpr(name,constraints,x,form,pure) ->
- (rebuild_mcode None).V0.rebuilder_expression
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.ExprTag(exp)) -> exp
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- let new_types =
- match x with
- None -> None
- | Some types ->
- let rec renamer = function
- Type_cocci.MetaType(name,keep,inherited) ->
- (match
- lookup (name,(),(),(),None) bindings mv_bindings
- with
- Common.Left(Ast0.TypeCTag(t)) ->
- Ast0.ast0_type_to_type t
- | Common.Left(_) ->
- failwith "iso pattern: unexpected type"
- | Common.Right(new_mv) ->
- Type_cocci.MetaType(new_mv,keep,inherited))
- | Type_cocci.ConstVol(cv,ty) ->
- Type_cocci.ConstVol(cv,renamer ty)
- | Type_cocci.Pointer(ty) ->
- Type_cocci.Pointer(renamer ty)
- | Type_cocci.FunctionPointer(ty) ->
- Type_cocci.FunctionPointer(renamer ty)
- | Type_cocci.Array(ty) ->
- Type_cocci.Array(renamer ty)
- | t -> t in
- Some(List.map renamer types) in
- Ast0.rewrap e
- (Ast0.MetaExpr
- (Ast0.set_mcode_data new_mv name,constraints,
- new_types,form,pure)))
- | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
- | Ast0.MetaExprList(namea,lenname,pure) ->
- failwith "metaexprlist not supported"
- | Ast0.Unary(exp,unop) ->
- (match Ast0.unwrap_mcode unop with
- Ast.Not ->
- let was_meta =
- (* k e doesn't change the outer structure of the term,
- only the metavars *)
- match Ast0.unwrap old_e with
- Ast0.Unary(exp,_) ->
- (match Ast0.unwrap exp with
- Ast0.MetaExpr(name,constraints,x,form,pure) -> true
- | _ -> false)
- | _ -> failwith "not possible" in
- let nomodif e =
- let mc = Ast0.get_mcodekind exp in
- match mc with
- Ast0.MINUS(x) ->
- (match !x with
- ([],_) -> true
- | _ -> false)
- | Ast0.CONTEXT(x) | Ast0.MIXED(x) ->
- (match !x with
- (Ast.NOTHING,_,_) -> true
- | _ -> false)
- | _ -> failwith "plus not possible" in
- if was_meta && nomodif exp && nomodif e
- then
- let idcont x = x in
- let rec negate e (*for rewrapping*) res (*code to process*) k =
- (* k accumulates parens, to keep negation outside if no
- propagation is possible *)
- match Ast0.unwrap res with
- Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not ->
- k (Ast0.rewrap e (Ast0.unwrap e1))
- | Ast0.Edots(_,_) -> k (Ast0.rewrap e (Ast0.unwrap res))
- | Ast0.Paren(lp,e,rp) ->
- negate e e
- (function x ->
- k (Ast0.rewrap res (Ast0.Paren(lp,x,rp))))
- | Ast0.Binary(e1,op,e2) ->
- let reb nop = Ast0.rewrap_mcode op (Ast.Logical(nop)) in
- let k1 x = k (Ast0.rewrap e x) in
- (match Ast0.unwrap_mcode op with
- Ast.Logical(Ast.Inf) ->
- k1 (Ast0.Binary(e1,reb Ast.SupEq,e2))
- | Ast.Logical(Ast.Sup) ->
- k1 (Ast0.Binary(e1,reb Ast.InfEq,e2))
- | Ast.Logical(Ast.InfEq) ->
- k1 (Ast0.Binary(e1,reb Ast.Sup,e2))
- | Ast.Logical(Ast.SupEq) ->
- k1 (Ast0.Binary(e1,reb Ast.Inf,e2))
- | Ast.Logical(Ast.Eq) ->
- k1 (Ast0.Binary(e1,reb Ast.NotEq,e2))
- | Ast.Logical(Ast.NotEq) ->
- k1 (Ast0.Binary(e1,reb Ast.Eq,e2))
- | Ast.Logical(Ast.AndLog) ->
- k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.OrLog,
- negate e2 e2 idcont))
- | Ast.Logical(Ast.OrLog) ->
- k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.AndLog,
- negate e2 e2 idcont))
- | _ ->
- Ast0.rewrap e
- (Ast0.Unary(k res,Ast0.rewrap_mcode op Ast.Not)))
- | Ast0.DisjExpr(lp,exps,mids,rp) ->
- (* use res because it is the transformed argument *)
- let exps = List.map (function e -> negate e e k) exps in
- Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp))
- | _ ->
- (*use e, because this might be the toplevel expression*)
- Ast0.rewrap e
- (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not)) in
- negate e exp idcont
- else e
- | _ -> e)
- | Ast0.Edots(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Edots(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | Ast0.Ecircles(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Ecircles(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | Ast0.Estars(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Estars(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | _ -> e in
- if Ast0.get_test_exp old_e then Ast0.set_test_exp e1 else e1 in
-
- let tyfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaType(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_typeC
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.TypeCTag(ty)) -> ty
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaType(Ast0.set_mcode_data new_mv name,pure)))
- | _ -> e in
-
- let declfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.Ddots(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.DeclTag(exp) -> Ast0.rewrap e (Ast0.Ddots(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | _ -> e in
-
- let paramfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaParam(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_parameter
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.ParamTag(param)) -> param
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaParam(Ast0.set_mcode_data new_mv name, pure)))
- | Ast0.MetaParamList(name,lenname,pure) ->
- failwith "metaparamlist not supported"
- | _ -> e in
-
- let whenfn (_,v) =
- match v with
- Ast0.DotsStmtTag(stms) -> Ast0.WhenNot stms
- | Ast0.StmtTag(stm) -> Ast0.WhenAlways stm
- | Ast0.IsoWhenTTag(stm) -> Ast0.WhenNotTrue stm
- | Ast0.IsoWhenFTag(stm) -> Ast0.WhenNotFalse stm
- | Ast0.IsoWhenTag(x) -> Ast0.WhenModifier(x)
- | _ -> failwith "unexpected binding" in
-
- let stmtfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaStmt(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_statement
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.StmtTag(stm)) -> stm
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaStmt(Ast0.set_mcode_data new_mv name,pure)))
- | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
- | Ast0.Dots(d,_) ->
- Ast0.rewrap e
- (Ast0.Dots
- (d,
- List.map whenfn
- (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
- | Ast0.Circles(d,_) ->
- Ast0.rewrap e
- (Ast0.Circles
- (d,
- List.map whenfn
- (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
- | Ast0.Stars(d,_) ->
- Ast0.rewrap e
- (Ast0.Stars
- (d,
- List.map whenfn
- (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
- | _ -> e in
-
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- (dots elist) donothing (dots plist) (dots slist) donothing donothing
- identfn exprfn tyfn donothing paramfn declfn stmtfn donothing donothing
-
-(* --------------------------------------------------------------------- *)
-
-let is_minus e =
- match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
-
-let context_required e = not(is_minus e) && not !Flag.sgrep_mode2
-
-let disj_fail bindings e =
- match bindings with
- Some x -> Printf.fprintf stderr "no disj available at this type"; e
- | None -> e
-
-(* isomorphism code is by default CONTEXT *)
-let merge_plus model_mcode e_mcode =
- match model_mcode with
- Ast0.MINUS(mc) ->
- (* add the replacement information at the root *)
- (match e_mcode with
- Ast0.MINUS(emc) ->
- emc :=
- (match (!mc,!emc) with
- (([],_),(x,t)) | ((x,_),([],t)) -> (x,t)
- | _ -> failwith "how can we combine minuses?")
- | _ -> failwith "not possible 6")
- | Ast0.CONTEXT(mc) ->
- (match e_mcode with
- Ast0.CONTEXT(emc) ->
- (* keep the logical line info as in the model *)
- let (mba,tb,ta) = !mc in
- let (eba,_,_) = !emc in
- (* merging may be required when a term is replaced by a subterm *)
- let merged =
- match (mba,eba) with
- (x,Ast.NOTHING) | (Ast.NOTHING,x) -> x
- | (Ast.BEFORE(b1),Ast.BEFORE(b2)) -> Ast.BEFORE(b1@b2)
- | (Ast.BEFORE(b),Ast.AFTER(a)) -> Ast.BEFOREAFTER(b,a)
- | (Ast.BEFORE(b1),Ast.BEFOREAFTER(b2,a)) ->
- Ast.BEFOREAFTER(b1@b2,a)
- | (Ast.AFTER(a),Ast.BEFORE(b)) -> Ast.BEFOREAFTER(b,a)
- | (Ast.AFTER(a1),Ast.AFTER(a2)) ->Ast.AFTER(a2@a1)
- | (Ast.AFTER(a1),Ast.BEFOREAFTER(b,a2)) -> Ast.BEFOREAFTER(b,a2@a1)
- | (Ast.BEFOREAFTER(b1,a),Ast.BEFORE(b2)) ->
- Ast.BEFOREAFTER(b1@b2,a)
- | (Ast.BEFOREAFTER(b,a1),Ast.AFTER(a2)) ->
- Ast.BEFOREAFTER(b,a2@a1)
- | (Ast.BEFOREAFTER(b1,a1),Ast.BEFOREAFTER(b2,a2)) ->
- Ast.BEFOREAFTER(b1@b2,a2@a1) in
- emc := (merged,tb,ta)
- | Ast0.MINUS(emc) ->
- let (anything_bef_aft,_,_) = !mc in
- let (anythings,t) = !emc in
- emc :=
- (match anything_bef_aft with
- Ast.BEFORE(b) -> (b@anythings,t)
- | Ast.AFTER(a) -> (anythings@a,t)
- | Ast.BEFOREAFTER(b,a) -> (b@anythings@a,t)
- | Ast.NOTHING -> (anythings,t))
- | _ -> failwith "not possible 7")
- | Ast0.MIXED(_) -> failwith "not possible 8"
- | Ast0.PLUS -> failwith "not possible 9"
-
-let copy_plus printer minusify model e =
- if !Flag.sgrep_mode2
- then e (* no plus code, can cause a "not possible" error, so just avoid it *)
- else
- let e =
- match Ast0.get_mcodekind model with
- Ast0.MINUS(mc) -> minusify e
- | Ast0.CONTEXT(mc) -> e
- | _ -> failwith "not possible: copy_plus\n" in
- merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e);
- e
-
-let copy_minus printer minusify model e =
- match Ast0.get_mcodekind model with
- Ast0.MINUS(mc) -> minusify e
- | Ast0.CONTEXT(mc) -> e
- | Ast0.MIXED(_) ->
- if !Flag.sgrep_mode2
- then e
- else failwith "not possible 8"
- | Ast0.PLUS -> failwith "not possible 9"
-
-let whencode_allowed prev_ecount prev_icount prev_dcount
- ecount icount dcount rest =
- (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
- won't be tested *)
- let other_ecount = (* number of edots *)
- List.fold_left (function rest -> function (_,ec,ic,dc) -> ec + rest)
- prev_ecount rest in
- let other_icount = (* number of dots *)
- List.fold_left (function rest -> function (_,ec,ic,dc) -> ic + rest)
- prev_icount rest in
- let other_dcount = (* number of dots *)
- List.fold_left (function rest -> function (_,ec,ic,dc) -> dc + rest)
- prev_dcount rest in
- (ecount = 0 or other_ecount = 0, icount = 0 or other_icount = 0,
- dcount = 0 or other_dcount = 0)
-
-(* copy the befores and afters to the instantiated code *)
-let extra_copy_stmt_plus model e =
- (if not !Flag.sgrep_mode2 (* sgrep has no plus code, so nothing to do *)
- then
- (match Ast0.unwrap model with
- Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
- | Ast0.Decl((info,bef),_) ->
- (match Ast0.unwrap e with
- Ast0.FunDecl((info,bef1),_,_,_,_,_,_,_,_)
- | Ast0.Decl((info,bef1),_) ->
- merge_plus bef bef1
- | _ -> merge_plus bef (Ast0.get_mcodekind e))
- | Ast0.IfThen(_,_,_,_,_,(info,aft))
- | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
- | Ast0.While(_,_,_,_,_,(info,aft))
- | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft))
- | Ast0.Iterator(_,_,_,_,_,(info,aft)) ->
- (match Ast0.unwrap e with
- Ast0.IfThen(_,_,_,_,_,(info,aft1))
- | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft1))
- | Ast0.While(_,_,_,_,_,(info,aft1))
- | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft1))
- | Ast0.Iterator(_,_,_,_,_,(info,aft1)) ->
- merge_plus aft aft1
- | _ -> merge_plus aft (Ast0.get_mcodekind e))
- | _ -> ()));
- e
-
-let extra_copy_other_plus model e = e
-
-(* --------------------------------------------------------------------- *)
-
-let mv_count = ref 0
-let new_mv (_,s) =
- let ct = !mv_count in
- mv_count := !mv_count + 1;
- "_"^s^"_"^(string_of_int ct)
-
-let get_name = function
- Ast.MetaIdDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaIdDecl(ar,nm))
- | Ast.MetaFreshIdDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaFreshIdDecl(ar,nm))
- | Ast.MetaTypeDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaTypeDecl(ar,nm))
- | Ast.MetaListlenDecl(nm) ->
- failwith "should not be rebuilt"
- | Ast.MetaParamDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaParamDecl(ar,nm))
- | Ast.MetaParamListDecl(ar,nm,nm1) ->
- (nm,function nm -> Ast.MetaParamListDecl(ar,nm,nm1))
- | Ast.MetaConstDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaConstDecl(ar,nm,ty))
- | Ast.MetaErrDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaErrDecl(ar,nm))
- | Ast.MetaExpDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaExpDecl(ar,nm,ty))
- | Ast.MetaIdExpDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaIdExpDecl(ar,nm,ty))
- | Ast.MetaLocalIdExpDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaLocalIdExpDecl(ar,nm,ty))
- | Ast.MetaExpListDecl(ar,nm,nm1) ->
- (nm,function nm -> Ast.MetaExpListDecl(ar,nm,nm1))
- | Ast.MetaStmDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaStmDecl(ar,nm))
- | Ast.MetaStmListDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaStmListDecl(ar,nm))
- | Ast.MetaFuncDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaFuncDecl(ar,nm))
- | Ast.MetaLocalFuncDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaLocalFuncDecl(ar,nm))
- | Ast.MetaPosDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaPosDecl(ar,nm))
- | Ast.MetaDeclarerDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaDeclarerDecl(ar,nm))
- | Ast.MetaIteratorDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaIteratorDecl(ar,nm))
-
-let make_new_metavars metavars bindings =
- let new_metavars =
- List.filter
- (function mv ->
- let (s,_) = get_name mv in
- try let _ = List.assoc s bindings in false with Not_found -> true)
- metavars in
- List.split
- (List.map
- (function mv ->
- let (s,rebuild) = get_name mv in
- let new_s = (!current_rule,new_mv s) in
- (rebuild new_s, (s,new_s)))
- new_metavars)
-
-(* --------------------------------------------------------------------- *)
-
-let do_nothing x = x
-
-let mkdisj matcher metavars alts e instantiater mkiso disj_maker minusify
- rebuild_mcodes name printer extra_plus update_others =
- let call_instantiate bindings mv_bindings alts =
- List.concat
- (List.map
- (function (a,_,_,_) ->
- nub
- (* no need to create duplicates when the bindings have no effect *)
- (List.map
- (function bindings ->
- Ast0.set_iso
- (copy_plus printer minusify e
- (extra_plus e
- (instantiater bindings mv_bindings
- (rebuild_mcodes a))))
- (Common.union_set [(name,mkiso a)] (Ast0.get_iso e)))
- bindings))
- alts) in
- let rec inner_loop all_alts prev_ecount prev_icount prev_dcount = function
- [] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
- | ((pattern,ecount,icount,dcount)::rest) ->
- let wc =
- whencode_allowed prev_ecount prev_icount prev_dcount
- ecount dcount icount rest in
- (match matcher true (context_required e) wc pattern e init_env with
- Fail(reason) ->
- if reason = NonMatch || not !Flag_parsing_cocci.show_iso_failures
- then ()
- else
- (match matcher false false wc pattern e init_env with
- OK _ ->
- interpret_reason name (Ast0.get_line e) reason
- (function () -> printer e)
- | _ -> ());
- inner_loop all_alts (prev_ecount + ecount) (prev_icount + icount)
- (prev_dcount + dcount) rest
- | OK (bindings : (((string * string) * 'a) list list)) ->
- let all_alts =
- (* apply update_others to all patterns other than the matched
- one. This is used to desigate the others as test
- expressions in the TestExpression case *)
- (List.map
- (function (x,e,i,d) as all ->
- if x = pattern
- then all
- else (update_others x,e,i,d))
- (List.hd all_alts)) ::
- (List.map
- (List.map (function (x,e,i,d) -> (update_others x,e,i,d)))
- (List.tl all_alts)) in
- (match List.concat all_alts with
- [x] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
- | all_alts ->
- let (new_metavars,mv_bindings) =
- make_new_metavars metavars (nub(List.concat bindings)) in
- Common.Right
- (new_metavars,
- call_instantiate bindings mv_bindings all_alts))) in
- let rec outer_loop prev_ecount prev_icount prev_dcount = function
- [] | [[_]] (*only one alternative*) -> ([],e) (* nothing matched *)
- | (alts::rest) as all_alts ->
- match inner_loop all_alts prev_ecount prev_icount prev_dcount alts with
- Common.Left(prev_ecount, prev_icount, prev_dcount) ->
- outer_loop prev_ecount prev_icount prev_dcount rest
- | Common.Right (new_metavars,res) ->
- (new_metavars,
- copy_minus printer minusify e (disj_maker res)) in
- outer_loop 0 0 0 alts
-
-(* no one should ever look at the information stored in these mcodes *)
-let disj_starter lst =
- let old_info = Ast0.get_info(List.hd lst) in
- let info =
- { old_info with
- Ast0.line_end = old_info.Ast0.line_start;
- Ast0.logical_end = old_info.Ast0.logical_start;
- Ast0.attachable_start = false; Ast0.attachable_end = false;
- Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.strings_before = []; Ast0.strings_after = [] } in
- Ast0.make_mcode_info "(" info
-
-let disj_ender lst =
- let old_info = Ast0.get_info(List.hd lst) in
- let info =
- { old_info with
- Ast0.line_start = old_info.Ast0.line_end;
- Ast0.logical_start = old_info.Ast0.logical_end;
- Ast0.attachable_start = false; Ast0.attachable_end = false;
- Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.strings_before = []; Ast0.strings_after = [] } in
- Ast0.make_mcode_info ")" info
-
-let disj_mid _ = Ast0.make_mcode "|"
-
-let make_disj_type tl =
- let mids =
- match tl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap (Ast0.DisjType(disj_starter tl,tl,mids,disj_ender tl))
-let make_disj_stmt_list tl =
- let mids =
- match tl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap (Ast0.Disj(disj_starter tl,tl,mids,disj_ender tl))
-let make_disj_expr model el =
- let mids =
- match el with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- let update_arg x =
- if Ast0.get_arg_exp model then Ast0.set_arg_exp x else x in
- let update_test x =
- let x = if Ast0.get_test_pos model then Ast0.set_test_pos x else x in
- if Ast0.get_test_exp model then Ast0.set_test_exp x else x in
- let el = List.map update_arg (List.map update_test el) in
- Ast0.context_wrap (Ast0.DisjExpr(disj_starter el,el,mids,disj_ender el))
-let make_disj_decl dl =
- let mids =
- match dl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap (Ast0.DisjDecl(disj_starter dl,dl,mids,disj_ender dl))
-let make_disj_stmt sl =
- let dotify x = Ast0.context_wrap (Ast0.DOTS[x]) in
- let mids =
- match sl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap
- (Ast0.Disj(disj_starter sl,List.map dotify sl,mids,disj_ender sl))
-
-let transform_type (metavars,alts,name) e =
- match alts with
- (Ast0.TypeCTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
- let alts =
- List.map
- (List.map
- (function
- Ast0.TypeCTag(p) ->
- (p,count_edots.V0.combiner_typeC p,
- count_idots.V0.combiner_typeC p,
- count_dots.V0.combiner_typeC p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_typeC metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_typeC)
- (function t -> Ast0.TypeCTag t)
- make_disj_type make_minus.V0.rebuilder_typeC
- (rebuild_mcode start_line).V0.rebuilder_typeC
- name Unparse_ast0.typeC extra_copy_other_plus do_nothing
- | _ -> ([],e)
-
-
-let transform_expr (metavars,alts,name) e =
- let process update_others =
- (* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
- let alts =
- List.map
- (List.map
- (function
- Ast0.ExprTag(p) | Ast0.ArgExprTag(p) | Ast0.TestExprTag(p) ->
- (p,count_edots.V0.combiner_expression p,
- count_idots.V0.combiner_expression p,
- count_dots.V0.combiner_expression p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_expr metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_expression)
- (function e -> Ast0.ExprTag e)
- (make_disj_expr e)
- make_minus.V0.rebuilder_expression
- (rebuild_mcode start_line).V0.rebuilder_expression
- name Unparse_ast0.expression extra_copy_other_plus update_others in
- match alts with
- (Ast0.ExprTag(_)::_)::_ -> process do_nothing
- | (Ast0.ArgExprTag(_)::_)::_ when Ast0.get_arg_exp e -> process do_nothing
- | (Ast0.TestExprTag(_)::_)::_ when Ast0.get_test_pos e ->
- process Ast0.set_test_exp
- | _ -> ([],e)
-
-let transform_decl (metavars,alts,name) e =
- match alts with
- (Ast0.DeclTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some (Ast0.get_info e).Ast0.line_start in
- let alts =
- List.map
- (List.map
- (function
- Ast0.DeclTag(p) ->
- (p,count_edots.V0.combiner_declaration p,
- count_idots.V0.combiner_declaration p,
- count_dots.V0.combiner_declaration p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_decl metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_declaration)
- (function d -> Ast0.DeclTag d)
- make_disj_decl
- make_minus.V0.rebuilder_declaration
- (rebuild_mcode start_line).V0.rebuilder_declaration
- name Unparse_ast0.declaration extra_copy_other_plus do_nothing
- | _ -> ([],e)
-
-let transform_stmt (metavars,alts,name) e =
- match alts with
- (Ast0.StmtTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some (Ast0.get_info e).Ast0.line_start in
- let alts =
- List.map
- (List.map
- (function
- Ast0.StmtTag(p) ->
- (p,count_edots.V0.combiner_statement p,
- count_idots.V0.combiner_statement p,
- count_dots.V0.combiner_statement p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_statement metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_statement)
- (function s -> Ast0.StmtTag s)
- make_disj_stmt make_minus.V0.rebuilder_statement
- (rebuild_mcode start_line).V0.rebuilder_statement
- name (Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
- | _ -> ([],e)
-
-(* sort of a hack, because there is no disj at top level *)
-let transform_top (metavars,alts,name) e =
- match Ast0.unwrap e with
- Ast0.DECL(declstm) ->
- (try
- let strip alts =
- List.map
- (List.map
- (function
- Ast0.DotsStmtTag(d) ->
- (match Ast0.unwrap d with
- Ast0.DOTS([s]) -> Ast0.StmtTag(s)
- | _ -> raise (Failure ""))
- | _ -> raise (Failure "")))
- alts in
- let (mv,s) = transform_stmt (metavars,strip alts,name) declstm in
- (mv,Ast0.rewrap e (Ast0.DECL(s)))
- with Failure _ -> ([],e))
- | Ast0.CODE(stmts) ->
- let (mv,res) =
- match alts with
- (Ast0.DotsStmtTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
- let alts =
- List.map
- (List.map
- (function
- Ast0.DotsStmtTag(p) ->
- (p,count_edots.V0.combiner_statement_dots p,
- count_idots.V0.combiner_statement_dots p,
- count_dots.V0.combiner_statement_dots p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_statement_dots metavars alts stmts
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_statement_dots)
- (function s -> Ast0.DotsStmtTag s)
- (function x ->
- Ast0.rewrap e (Ast0.DOTS([make_disj_stmt_list x])))
- (function x ->
- make_minus.V0.rebuilder_statement_dots x)
- (rebuild_mcode start_line).V0.rebuilder_statement_dots
- name Unparse_ast0.statement_dots extra_copy_other_plus do_nothing
- | _ -> ([],stmts) in
- (mv,Ast0.rewrap e (Ast0.CODE res))
- | _ -> ([],e)
-
-(* --------------------------------------------------------------------- *)
-
-let transform (alts : isomorphism) t =
- (* the following ugliness is because rebuilder only returns a new term *)
- let extra_meta_decls = ref ([] : Ast_cocci.metavar list) in
- let mcode x = x in
- let donothing r k e = k e in
- let exprfn r k e =
- let (extra_meta,exp) = transform_expr alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- exp in
-
- let declfn r k e =
- let (extra_meta,dec) = transform_decl alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- dec in
-
- let stmtfn r k e =
- let (extra_meta,stm) = transform_stmt alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- stm in
-
- let typefn r k e =
- let continue =
- match Ast0.unwrap e with
- Ast0.Signed(signb,tyb) ->
- (* Hack! How else to prevent iso from applying under an
- unsigned??? *)
- e
- | _ -> k e in
- let (extra_meta,ty) = transform_type alts continue in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- ty in
-
- let topfn r k e =
- let (extra_meta,ty) = transform_top alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- ty in
-
- let res =
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing exprfn typefn donothing donothing declfn stmtfn
- donothing topfn in
- let res = res.V0.rebuilder_top_level t in
- (!extra_meta_decls,res)
-
-(* --------------------------------------------------------------------- *)
-
-(* should be done by functorizing the parser to use wrap or context_wrap *)
-let rewrap =
- let mcode (x,a,i,mc,pos) = (x,a,i,Ast0.context_befaft(),pos) in
- let donothing r k e = Ast0.context_wrap(Ast0.unwrap(k e)) in
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing
-
-let rewrap_anything = function
- Ast0.DotsExprTag(d) ->
- Ast0.DotsExprTag(rewrap.V0.rebuilder_expression_dots d)
- | Ast0.DotsInitTag(d) ->
- Ast0.DotsInitTag(rewrap.V0.rebuilder_initialiser_list d)
- | Ast0.DotsParamTag(d) ->
- Ast0.DotsParamTag(rewrap.V0.rebuilder_parameter_list d)
- | Ast0.DotsStmtTag(d) ->
- Ast0.DotsStmtTag(rewrap.V0.rebuilder_statement_dots d)
- | Ast0.DotsDeclTag(d) ->
- Ast0.DotsDeclTag(rewrap.V0.rebuilder_declaration_dots d)
- | Ast0.DotsCaseTag(d) ->
- Ast0.DotsCaseTag(rewrap.V0.rebuilder_case_line_dots d)
- | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.V0.rebuilder_ident d)
- | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.ArgExprTag(d) -> Ast0.ArgExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.TestExprTag(d) -> Ast0.TestExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.V0.rebuilder_typeC d)
- | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.V0.rebuilder_initialiser d)
- | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.V0.rebuilder_parameter d)
- | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.V0.rebuilder_declaration d)
- | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.V0.rebuilder_statement d)
- | Ast0.CaseLineTag(d) -> Ast0.CaseLineTag(rewrap.V0.rebuilder_case_line d)
- | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.V0.rebuilder_top_level d)
- | Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) ->
- failwith "only for isos within iso phase"
- | Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p)
-
-(* --------------------------------------------------------------------- *)
-
-let apply_isos isos rule rule_name =
- if isos = []
- then ([],rule)
- else
- begin
- current_rule := rule_name;
- let isos =
- List.map
- (function (metavars,iso,name) ->
- (metavars,List.map (List.map rewrap_anything) iso,name))
- isos in
- let (extra_meta,rule) =
- List.split
- (List.map
- (function t ->
- List.fold_left
- (function (extra_meta,t) -> function iso ->
- let (new_extra_meta,t) = transform iso t in
- (new_extra_meta@extra_meta,t))
- ([],t) isos)
- rule) in
- (List.concat extra_meta, Compute_lines.compute_lines rule)
- end
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* Potential problem: offset of mcode is not updated when an iso is
-instantiated, implying that a term may end up with many mcodes with the
-same offset. On the other hand, at the moment offset only seems to be used
-before this phase. Furthermore add_dot_binding relies on the offset to
-remain the same between matching an iso and instantiating it with bindings. *)
-
-(* --------------------------------------------------------------------- *)
-(* match a SmPL expression against a SmPL abstract syntax tree,
-either - or + *)
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module V0 = Visitor_ast0
-
-let current_rule = ref ""
-
-(* --------------------------------------------------------------------- *)
-
-type isomorphism =
- Ast_cocci.metavar list * Ast0_cocci.anything list list * string (* name *)
-
-let strip_info =
- let mcode (term,_,_,_,_) =
- (term,Ast0.NONE,Ast0.default_info(),Ast0.PLUS,ref Ast0.NoMetaPos) in
- let donothing r k e =
- let x = k e in
- {(Ast0.wrap (Ast0.unwrap x)) with
- Ast0.mcodekind = ref Ast0.PLUS;
- Ast0.true_if_test = x.Ast0.true_if_test} in
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing
-
-let anything_equal = function
- (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) ->
- failwith "not a possible variable binding" (*not sure why these are pbs*)
- | (Ast0.DotsInitTag(d1),Ast0.DotsInitTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) ->
- (strip_info.V0.rebuilder_statement_dots d1) =
- (strip_info.V0.rebuilder_statement_dots d2)
- | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) ->
- failwith "not a possible variable binding"
- | (Ast0.IdentTag(d1),Ast0.IdentTag(d2)) ->
- (strip_info.V0.rebuilder_ident d1) = (strip_info.V0.rebuilder_ident d2)
- | (Ast0.ExprTag(d1),Ast0.ExprTag(d2)) ->
- (strip_info.V0.rebuilder_expression d1) =
- (strip_info.V0.rebuilder_expression d2)
- | (Ast0.ArgExprTag(_),_) | (_,Ast0.ArgExprTag(_)) ->
- failwith "not possible - only in isos1"
- | (Ast0.TestExprTag(_),_) | (_,Ast0.TestExprTag(_)) ->
- failwith "not possible - only in isos1"
- | (Ast0.TypeCTag(d1),Ast0.TypeCTag(d2)) ->
- (strip_info.V0.rebuilder_typeC d1) =
- (strip_info.V0.rebuilder_typeC d2)
- | (Ast0.InitTag(d1),Ast0.InitTag(d2)) ->
- (strip_info.V0.rebuilder_initialiser d1) =
- (strip_info.V0.rebuilder_initialiser d2)
- | (Ast0.ParamTag(d1),Ast0.ParamTag(d2)) ->
- (strip_info.V0.rebuilder_parameter d1) =
- (strip_info.V0.rebuilder_parameter d2)
- | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) ->
- (strip_info.V0.rebuilder_declaration d1) =
- (strip_info.V0.rebuilder_declaration d2)
- | (Ast0.StmtTag(d1),Ast0.StmtTag(d2)) ->
- (strip_info.V0.rebuilder_statement d1) =
- (strip_info.V0.rebuilder_statement d2)
- | (Ast0.CaseLineTag(d1),Ast0.CaseLineTag(d2)) ->
- (strip_info.V0.rebuilder_case_line d1) =
- (strip_info.V0.rebuilder_case_line d2)
- | (Ast0.TopTag(d1),Ast0.TopTag(d2)) ->
- (strip_info.V0.rebuilder_top_level d1) =
- (strip_info.V0.rebuilder_top_level d2)
- | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_)) ->
- failwith "only for isos within iso phase"
- | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
- failwith "only for isos within iso phase"
- | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_)) ->
- failwith "only for isos within iso phase"
- | _ -> false
-
-let term (var1,_,_,_,_) = var1
-let dot_term (var1,_,info,_,_) = ("", var1 ^ (string_of_int info.Ast0.offset))
-
-
-type reason =
- NotPure of Ast0.pure * (string * string) * Ast0.anything
- | NotPureLength of (string * string)
- | ContextRequired of Ast0.anything
- | NonMatch
- | Braces of Ast0.statement
- | Position of string * string
- | TypeMatch of reason list
-
-let rec interpret_reason name line reason printer =
- Printf.printf
- "warning: iso %s does not match the code below on line %d\n" name line;
- printer(); Format.print_newline();
- match reason with
- NotPure(Ast0.Pure,(_,var),nonpure) ->
- Printf.printf
- "pure metavariable %s is matched against the following nonpure code:\n"
- var;
- Unparse_ast0.unparse_anything nonpure
- | NotPure(Ast0.Context,(_,var),nonpure) ->
- Printf.printf
- "context metavariable %s is matched against the following\nnoncontext code:\n"
- var;
- Unparse_ast0.unparse_anything nonpure
- | NotPure(Ast0.PureContext,(_,var),nonpure) ->
- Printf.printf
- "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
- var;
- Unparse_ast0.unparse_anything nonpure
- | NotPureLength((_,var)) ->
- Printf.printf
- "pure metavariable %s is matched against too much or too little code\n"
- var;
- | ContextRequired(term) ->
- Printf.printf
- "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
- Unparse_ast0.unparse_anything term
- | Braces(s) ->
- Printf.printf "braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
- Unparse_ast0.statement "" s;
- Format.print_newline()
- | Position(rule,name) ->
- Printf.printf "position variable %s.%s conflicts with an isomorphism\n"
- rule name;
- | TypeMatch reason_list ->
- List.iter (function r -> interpret_reason name line r printer)
- reason_list
- | _ -> failwith "not possible"
-
-type 'a either = OK of 'a | Fail of reason
-
-let add_binding var exp bindings =
- let var = term var in
- let attempt bindings =
- try
- let cur = List.assoc var bindings in
- if anything_equal(exp,cur) then [bindings] else []
- with Not_found -> [((var,exp)::bindings)] in
- match List.concat(List.map attempt bindings) with
- [] -> Fail NonMatch
- | x -> OK x
-
-let add_dot_binding var exp bindings =
- let var = dot_term var in
- let attempt bindings =
- try
- let cur = List.assoc var bindings in
- if anything_equal(exp,cur) then [bindings] else []
- with Not_found -> [((var,exp)::bindings)] in
- match List.concat(List.map attempt bindings) with
- [] -> Fail NonMatch
- | x -> OK x
-
-(* multi-valued *)
-let add_multi_dot_binding var exp bindings =
- let var = dot_term var in
- let attempt bindings = [((var,exp)::bindings)] in
- match List.concat(List.map attempt bindings) with
- [] -> Fail NonMatch
- | x -> OK x
-
-let rec nub ls =
- match ls with
- [] -> []
- | (x::xs) when (List.mem x xs) -> nub xs
- | (x::xs) -> x::(nub xs)
-
-(* --------------------------------------------------------------------- *)
-
-let init_env = [[]]
-
-let debug str m binding =
- let res = m binding in
- (match res with
- None -> Printf.printf "%s: failed\n" str
- | Some binding ->
- List.iter
- (function binding ->
- Printf.printf "%s: %s\n" str
- (String.concat " " (List.map (function (x,_) -> x) binding)))
- binding);
- res
-
-let conjunct_bindings
- (m1 : 'binding -> 'binding either)
- (m2 : 'binding -> 'binding either)
- (binding : 'binding) : 'binding either =
- match m1 binding with Fail(reason) -> Fail(reason) | OK binding -> m2 binding
-
-let rec conjunct_many_bindings = function
- [] -> failwith "not possible"
- | [x] -> x
- | x::xs -> conjunct_bindings x (conjunct_many_bindings xs)
-
-let mcode_equal (x,_,_,_,_) (y,_,_,_,_) = x = y
-
-let return b binding = if b then OK binding else Fail NonMatch
-let return_false reason binding = Fail reason
-
-let match_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> return true
- | _ -> return false
-
-let bool_match_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> true
- | _ -> false
-
-(* context_required is for the example
- if (
-+ (int * )
- x == NULL)
- where we can't change x == NULL to eg NULL == x. So there can either be
- nothing attached to the root or the term has to be all removed.
- if would be nice if we knew more about the relationship between the - and +
- code, because in the case where the + code is a separate statement in a
- sequence, this is not a problem. Perhaps something could be done in
- insert_plus
-
- The example seems strange. Why isn't the cast attached to x?
- *)
-let is_context e =
- !Flag.sgrep_mode2 or (* everything is context for sgrep *)
- (match Ast0.get_mcodekind e with
- Ast0.CONTEXT(cell) -> true
- | _ -> false)
-
-(* needs a special case when there is a Disj or an empty DOTS
- the following stops at the statement level, and gives true if one
- statement is replaced by another *)
-let rec is_pure_context s =
- !Flag.sgrep_mode2 or (* everything is context for sgrep *)
- (match Ast0.unwrap s with
- Ast0.Disj(starter,statement_dots_list,mids,ender) ->
- List.for_all
- (function x ->
- match Ast0.undots x with
- [s] -> is_pure_context s
- | _ -> false (* could we do better? *))
- statement_dots_list
- | _ ->
- (match Ast0.get_mcodekind s with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> true
- | _ -> false)
- | Ast0.MINUS(mc) ->
- (match !mc with
- (* do better for the common case of replacing a stmt by another one *)
- ([[Ast.StatementTag(s)]],_) ->
- (match Ast.unwrap s with
- Ast.IfThen(_,_,_) -> false (* potentially dangerous *)
- | _ -> true)
- | (_,_) -> false)
- | _ -> false))
-
-let is_minus e =
- match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
-
-let match_list matcher is_list_matcher do_list_match la lb =
- let rec loop = function
- ([],[]) -> return true
- | ([x],lb) when is_list_matcher x -> do_list_match x lb
- | (x::xs,y::ys) -> conjunct_bindings (matcher x y) (loop (xs,ys))
- | _ -> return false in
- loop (la,lb)
-
-let match_maker checks_needed context_required whencode_allowed =
-
- let check_mcode pmc cmc binding =
- if checks_needed
- then
- match Ast0.get_pos cmc with
- (Ast0.MetaPos (name,_,_)) as x ->
- (match Ast0.get_pos pmc with
- Ast0.MetaPos (name1,_,_) ->
- add_binding name1 (Ast0.MetaPosTag x) binding
- | Ast0.NoMetaPos ->
- let (rule,name) = Ast0.unwrap_mcode name in
- Fail (Position(rule,name)))
- | Ast0.NoMetaPos -> OK binding
- else OK binding in
-
- let match_dots matcher is_list_matcher do_list_match d1 d2 =
- match (Ast0.unwrap d1, Ast0.unwrap d2) with
- (Ast0.DOTS(la),Ast0.DOTS(lb))
- | (Ast0.CIRCLES(la),Ast0.CIRCLES(lb))
- | (Ast0.STARS(la),Ast0.STARS(lb)) ->
- match_list matcher is_list_matcher (do_list_match d2) la lb
- | _ -> return false in
-
- let is_elist_matcher el =
- match Ast0.unwrap el with Ast0.MetaExprList(_,_,_) -> true | _ -> false in
-
- let is_plist_matcher pl =
- match Ast0.unwrap pl with Ast0.MetaParamList(_,_,_) -> true | _ -> false in
-
- let is_slist_matcher pl =
- match Ast0.unwrap pl with Ast0.MetaStmtList(_,_) -> true | _ -> false in
-
- let no_list _ = false in
-
- let build_dots pattern data =
- match Ast0.unwrap pattern with
- Ast0.DOTS(_) -> Ast0.rewrap pattern (Ast0.DOTS(data))
- | Ast0.CIRCLES(_) -> Ast0.rewrap pattern (Ast0.CIRCLES(data))
- | Ast0.STARS(_) -> Ast0.rewrap pattern (Ast0.STARS(data)) in
-
- let pure_sp_code =
- let bind = Ast0.lub_pure in
- let option_default = Ast0.Context in
- let pure_mcodekind mc =
- if !Flag.sgrep_mode2
- then Ast0.PureContext
- else
- match mc with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> Ast0.PureContext
- | _ -> Ast0.Context)
- | Ast0.MINUS(mc) ->
- (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure)
- | _ -> Ast0.Impure in
- let donothing r k e =
- bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in
-
- let mcode m = pure_mcodekind (Ast0.get_mcode_mcodekind m) in
-
- (* a case for everything that has a metavariable *)
- (* pure is supposed to match only unitary metavars, not anything that
- contains only unitary metavars *)
- let ident r k i =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind i)) (k i))
- (match Ast0.unwrap i with
- Ast0.MetaId(name,_,pure) | Ast0.MetaFunc(name,_,pure)
- | Ast0.MetaLocalFunc(name,_,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let expression r k e =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e))
- (match Ast0.unwrap e with
- Ast0.MetaErr(name,_,pure)
- | Ast0.MetaExpr(name,_,_,_,pure) | Ast0.MetaExprList(name,_,pure) ->
- pure
- | _ -> Ast0.Impure) in
-
- let typeC r k t =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
- (match Ast0.unwrap t with
- Ast0.MetaType(name,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let init r k t =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
- (match Ast0.unwrap t with
- Ast0.MetaInit(name,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let param r k p =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind p)) (k p))
- (match Ast0.unwrap p with
- Ast0.MetaParam(name,pure) | Ast0.MetaParamList(name,_,pure) -> pure
- | _ -> Ast0.Impure) in
-
- let stmt r k s =
- bind (bind (pure_mcodekind (Ast0.get_mcodekind s)) (k s))
- (match Ast0.unwrap s with
- Ast0.MetaStmt(name,pure) | Ast0.MetaStmtList(name,pure) -> pure
- | _ -> Ast0.Impure) in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- ident expression typeC init param donothing stmt donothing
- donothing in
-
- let add_pure_list_binding name pure is_pure builder1 builder2 lst =
- match (checks_needed,pure) with
- (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
- (match lst with
- [x] ->
- if (Ast0.lub_pure (is_pure x) pure) = pure
- then add_binding name (builder1 lst)
- else return_false (NotPure (pure,term name,builder1 lst))
- | _ -> return_false (NotPureLength (term name)))
- | (false,_) | (_,Ast0.Impure) -> add_binding name (builder2 lst) in
-
- let add_pure_binding name pure is_pure builder x =
- match (checks_needed,pure) with
- (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
- if (Ast0.lub_pure (is_pure x) pure) = pure
- then add_binding name (builder x)
- else return_false (NotPure (pure,term name, builder x))
- | (false,_) | (_,Ast0.Impure) -> add_binding name (builder x) in
-
- let do_elist_match builder el lst =
- match Ast0.unwrap el with
- Ast0.MetaExprList(name,lenname,pure) ->
- (*how to handle lenname? should it be an option type and always None?*)
- failwith "expr list pattern not supported in iso"
- (*add_pure_list_binding name pure
- pure_sp_code.V0.combiner_expression
- (function lst -> Ast0.ExprTag(List.hd lst))
- (function lst -> Ast0.DotsExprTag(build_dots builder lst))
- lst*)
- | _ -> failwith "not possible" in
-
- let do_plist_match builder pl lst =
- match Ast0.unwrap pl with
- Ast0.MetaParamList(name,lename,pure) ->
- failwith "param list pattern not supported in iso"
- (*add_pure_list_binding name pure
- pure_sp_code.V0.combiner_parameter
- (function lst -> Ast0.ParamTag(List.hd lst))
- (function lst -> Ast0.DotsParamTag(build_dots builder lst))
- lst*)
- | _ -> failwith "not possible" in
-
- let do_slist_match builder sl lst =
- match Ast0.unwrap sl with
- Ast0.MetaStmtList(name,pure) ->
- add_pure_list_binding name pure
- pure_sp_code.V0.combiner_statement
- (function lst -> Ast0.StmtTag(List.hd lst))
- (function lst -> Ast0.DotsStmtTag(build_dots builder lst))
- lst
- | _ -> failwith "not possible" in
-
- let do_nolist_match _ _ = failwith "not possible" in
-
- let rec match_ident pattern id =
- match Ast0.unwrap pattern with
- Ast0.MetaId(name,_,pure) ->
- (add_pure_binding name pure pure_sp_code.V0.combiner_ident
- (function id -> Ast0.IdentTag id) id)
- | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
- | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context id
- then
- match (up,Ast0.unwrap id) with
- (Ast0.Id(namea),Ast0.Id(nameb)) ->
- if mcode_equal namea nameb
- then check_mcode namea nameb
- else return false
- | (Ast0.OptIdent(ida),Ast0.OptIdent(idb))
- | (Ast0.UniqueIdent(ida),Ast0.UniqueIdent(idb)) ->
- match_ident ida idb
- | (_,Ast0.OptIdent(idb))
- | (_,Ast0.UniqueIdent(idb)) -> match_ident pattern idb
- | _ -> return false
- else return_false (ContextRequired (Ast0.IdentTag id)) in
-
- (* should we do something about matching metavars against ...? *)
- let rec match_expr pattern expr =
- match Ast0.unwrap pattern with
- Ast0.MetaExpr(name,_,ty,form,pure) ->
- let form_ok =
- match (form,expr) with
- (Ast.ANY,_) -> true
- | (Ast.CONST,e) ->
- let rec matches e =
- match Ast0.unwrap e with
- Ast0.Constant(c) -> true
- | Ast0.Cast(lp,ty,rp,e) -> matches e
- | Ast0.SizeOfExpr(se,exp) -> true
- | Ast0.SizeOfType(se,lp,ty,rp) -> true
- | Ast0.MetaExpr(nm,_,_,Ast.CONST,p) ->
- (Ast0.lub_pure p pure) = pure
- | _ -> false in
- matches e
- | (Ast.ID,e) | (Ast.LocalID,e) ->
- let rec matches e =
- match Ast0.unwrap e with
- Ast0.Ident(c) -> true
- | Ast0.Cast(lp,ty,rp,e) -> matches e
- | Ast0.MetaExpr(nm,_,_,Ast.ID,p) ->
- (Ast0.lub_pure p pure) = pure
- | _ -> false in
- matches e in
- if form_ok
- then
- match ty with
- Some ts ->
- if List.exists
- (function Type_cocci.MetaType(_,_,_) -> true | _ -> false)
- ts
- then
- (match ts with
- [Type_cocci.MetaType(tyname,_,_)] ->
- let expty =
- match (Ast0.unwrap expr,Ast0.get_type expr) with
- (* easier than updating type inferencer to manage multiple
- types *)
- (Ast0.MetaExpr(_,_,Some tts,_,_),_) -> Some tts
- | (_,Some ty) -> Some [ty]
- | _ -> None in
- (match expty with
- Some expty ->
- let tyname = Ast0.rewrap_mcode name tyname in
- conjunct_bindings
- (add_pure_binding name pure
- pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr)
- (function bindings ->
- let attempts =
- List.map
- (function expty ->
- (try
- add_pure_binding tyname Ast0.Impure
- (function _ -> Ast0.Impure)
- (function ty -> Ast0.TypeCTag ty)
- (Ast0.rewrap expr
- (Ast0.reverse_type expty))
- bindings
- with Ast0.TyConv ->
- Printf.printf
- "warning: unconvertible type";
- return false bindings))
- expty in
- if List.exists
- (function Fail _ -> false | OK x -> true)
- attempts
- then
- (* not sure why this is ok. can there be more
- than one OK? *)
- OK (List.concat
- (List.map
- (function Fail _ -> [] | OK x -> x)
- attempts))
- else
- Fail
- (TypeMatch
- (List.map
- (function
- Fail r -> r
- | OK x -> failwith "not possible")
- attempts)))
- | _ ->
- (*Printf.printf
- "warning: type metavar can only match one type";*)
- return false)
- | _ ->
- failwith
- "mixture of metatype and other types not supported")
- else
- let expty = Ast0.get_type expr in
- if List.exists (function t -> Type_cocci.compatible t expty) ts
- then
- add_pure_binding name pure
- pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr
- else return false
- | None ->
- add_pure_binding name pure pure_sp_code.V0.combiner_expression
- (function expr -> Ast0.ExprTag expr)
- expr
- else return false
- | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
- | Ast0.MetaExprList(_,_,_) -> failwith "metaexprlist not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context expr
- then
- match (up,Ast0.unwrap expr) with
- (Ast0.Ident(ida),Ast0.Ident(idb)) ->
- match_ident ida idb
- | (Ast0.Constant(consta),Ast0.Constant(constb)) ->
- if mcode_equal consta constb
- then check_mcode consta constb
- else return false
- | (Ast0.FunCall(fna,lp1,argsa,rp1),Ast0.FunCall(fnb,lp,argsb,rp)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp; match_expr fna fnb;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb]
- | (Ast0.Assignment(lefta,opa,righta,_),
- Ast0.Assignment(leftb,opb,rightb,_)) ->
- if mcode_equal opa opb
- then
- conjunct_many_bindings
- [check_mcode opa opb; match_expr lefta leftb;
- match_expr righta rightb]
- else return false
- | (Ast0.CondExpr(exp1a,lp1,exp2a,rp1,exp3a),
- Ast0.CondExpr(exp1b,lp,exp2b,rp,exp3b)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- match_expr exp1a exp1b; match_option match_expr exp2a exp2b;
- match_expr exp3a exp3b]
- | (Ast0.Postfix(expa,opa),Ast0.Postfix(expb,opb)) ->
- if mcode_equal opa opb
- then
- conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
- else return false
- | (Ast0.Infix(expa,opa),Ast0.Infix(expb,opb)) ->
- if mcode_equal opa opb
- then
- conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
- else return false
- | (Ast0.Unary(expa,opa),Ast0.Unary(expb,opb)) ->
- if mcode_equal opa opb
- then
- conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
- else return false
- | (Ast0.Binary(lefta,opa,righta),Ast0.Binary(leftb,opb,rightb)) ->
- if mcode_equal opa opb
- then
- conjunct_many_bindings
- [check_mcode opa opb; match_expr lefta leftb;
- match_expr righta rightb]
- else return false
- | (Ast0.Paren(lp1,expa,rp1),Ast0.Paren(lp,expb,rp)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp; match_expr expa expb]
- | (Ast0.ArrayAccess(exp1a,lb1,exp2a,rb1),
- Ast0.ArrayAccess(exp1b,lb,exp2b,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_expr exp1a exp1b; match_expr exp2a exp2b]
- | (Ast0.RecordAccess(expa,opa,fielda),
- Ast0.RecordAccess(expb,op,fieldb))
- | (Ast0.RecordPtAccess(expa,opa,fielda),
- Ast0.RecordPtAccess(expb,op,fieldb)) ->
- conjunct_many_bindings
- [check_mcode opa op; match_expr expa expb;
- match_ident fielda fieldb]
- | (Ast0.Cast(lp1,tya,rp1,expa),Ast0.Cast(lp,tyb,rp,expb)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- match_typeC tya tyb; match_expr expa expb]
- | (Ast0.SizeOfExpr(szf1,expa),Ast0.SizeOfExpr(szf,expb)) ->
- conjunct_bindings (check_mcode szf1 szf) (match_expr expa expb)
- | (Ast0.SizeOfType(szf1,lp1,tya,rp1),
- Ast0.SizeOfType(szf,lp,tyb,rp)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode szf1 szf; match_typeC tya tyb]
- | (Ast0.TypeExp(tya),Ast0.TypeExp(tyb)) ->
- match_typeC tya tyb
- | (Ast0.EComma(cm1),Ast0.EComma(cm)) -> check_mcode cm1 cm
- | (Ast0.DisjExpr(_,expsa,_,_),_) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.NestExpr(_,exp_dotsa,_,_,_),_) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.Edots(d,None),Ast0.Edots(d1,None))
- | (Ast0.Ecircles(d,None),Ast0.Ecircles(d1,None))
- | (Ast0.Estars(d,None),Ast0.Estars(d1,None)) -> check_mcode d d1
- | (Ast0.Edots(ed,None),Ast0.Edots(ed1,Some wc))
- | (Ast0.Ecircles(ed,None),Ast0.Ecircles(ed1,Some wc))
- | (Ast0.Estars(ed,None),Ast0.Estars(ed1,Some wc)) ->
- (* hope that mcode of edots is unique somehow *)
- conjunct_bindings (check_mcode ed ed1)
- (let (edots_whencode_allowed,_,_) = whencode_allowed in
- if edots_whencode_allowed
- then add_dot_binding ed (Ast0.ExprTag wc)
- else
- (Printf.printf
- "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Edots(_,Some _),_) | (Ast0.Ecircles(_,Some _),_)
- | (Ast0.Estars(_,Some _),_) ->
- failwith "whencode not allowed in a pattern1"
- | (Ast0.OptExp(expa),Ast0.OptExp(expb))
- | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) -> match_expr expa expb
- | (_,Ast0.OptExp(expb))
- | (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb
- | _ -> return false
- else return_false (ContextRequired (Ast0.ExprTag expr))
-
-(* the special case for function types prevents the eg T X; -> T X = E; iso
- from applying, which doesn't seem very relevant, but it also avoids a
- mysterious bug that is obtained with eg int attach(...); *)
- and match_typeC pattern t =
- match Ast0.unwrap pattern with
- Ast0.MetaType(name,pure) ->
- (match Ast0.unwrap t with
- Ast0.FunctionType(tya,lp1a,paramsa,rp1a) -> return false
- | _ ->
- add_pure_binding name pure pure_sp_code.V0.combiner_typeC
- (function ty -> Ast0.TypeCTag ty)
- t)
- | up ->
- if not(checks_needed) or not(context_required) or is_context t
- then
- match (up,Ast0.unwrap t) with
- (Ast0.ConstVol(cva,tya),Ast0.ConstVol(cvb,tyb)) ->
- if mcode_equal cva cvb
- then
- conjunct_bindings (check_mcode cva cvb) (match_typeC tya tyb)
- else return false
- | (Ast0.BaseType(tya,stringsa),Ast0.BaseType(tyb,stringsb)) ->
- if tya = tyb
- then
- match_list check_mcode
- (function _ -> false) (function _ -> failwith "")
- stringsa stringsb
- else return false
- | (Ast0.Signed(signa,tya),Ast0.Signed(signb,tyb)) ->
- if mcode_equal signa signb
- then
- conjunct_bindings (check_mcode signa signb)
- (match_option match_typeC tya tyb)
- else return false
- | (Ast0.Pointer(tya,star1),Ast0.Pointer(tyb,star)) ->
- conjunct_bindings (check_mcode star1 star) (match_typeC tya tyb)
- | (Ast0.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
- Ast0.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) ->
- conjunct_many_bindings
- [check_mcode stara starb; check_mcode lp1a lp1b;
- check_mcode rp1a rp1b; check_mcode lp2a lp2b;
- check_mcode rp2a rp2b; match_typeC tya tyb;
- match_dots match_param is_plist_matcher
- do_plist_match paramsa paramsb]
- | (Ast0.FunctionType(tya,lp1a,paramsa,rp1a),
- Ast0.FunctionType(tyb,lp1b,paramsb,rp1b)) ->
- conjunct_many_bindings
- [check_mcode lp1a lp1b; check_mcode rp1a rp1b;
- match_option match_typeC tya tyb;
- match_dots match_param is_plist_matcher do_plist_match
- paramsa paramsb]
- | (Ast0.Array(tya,lb1,sizea,rb1),Ast0.Array(tyb,lb,sizeb,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_typeC tya tyb; match_option match_expr sizea sizeb]
- | (Ast0.EnumName(kinda,namea),Ast0.EnumName(kindb,nameb)) ->
- conjunct_bindings (check_mcode kinda kindb)
- (match_ident namea nameb)
- | (Ast0.StructUnionName(kinda,Some namea),
- Ast0.StructUnionName(kindb,Some nameb)) ->
- if mcode_equal kinda kindb
- then
- conjunct_bindings (check_mcode kinda kindb)
- (match_ident namea nameb)
- else return false
- | (Ast0.StructUnionDef(tya,lb1,declsa,rb1),
- Ast0.StructUnionDef(tyb,lb,declsb,rb)) ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_typeC tya tyb;
- match_dots match_decl no_list do_nolist_match declsa declsb]
- | (Ast0.TypeName(namea),Ast0.TypeName(nameb)) ->
- if mcode_equal namea nameb
- then check_mcode namea nameb
- else return false
- | (Ast0.DisjType(_,typesa,_,_),Ast0.DisjType(_,typesb,_,_)) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.OptType(tya),Ast0.OptType(tyb))
- | (Ast0.UniqueType(tya),Ast0.UniqueType(tyb)) -> match_typeC tya tyb
- | (_,Ast0.OptType(tyb))
- | (_,Ast0.UniqueType(tyb)) -> match_typeC pattern tyb
- | _ -> return false
- else return_false (ContextRequired (Ast0.TypeCTag t))
-
- and match_decl pattern d =
- if not(checks_needed) or not(context_required) or is_context d
- then
- match (Ast0.unwrap pattern,Ast0.unwrap d) with
- (Ast0.Init(stga,tya,ida,eq1,inia,sc1),
- Ast0.Init(stgb,tyb,idb,eq,inib,sc)) ->
- if bool_match_option mcode_equal stga stgb
- then
- conjunct_many_bindings
- [check_mcode eq1 eq; check_mcode sc1 sc;
- match_option check_mcode stga stgb;
- match_typeC tya tyb; match_ident ida idb;
- match_init inia inib]
- else return false
- | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) ->
- if bool_match_option mcode_equal stga stgb
- then
- conjunct_many_bindings
- [check_mcode sc1 sc; match_option check_mcode stga stgb;
- match_typeC tya tyb; match_ident ida idb]
- else return false
- | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1),
- Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) ->
- conjunct_many_bindings
- [match_ident namea nameb;
- check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode sc1 sc;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb]
- | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb)
- | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc)
- (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb))
- | (Ast0.DisjDecl(_,declsa,_,_),Ast0.DisjDecl(_,declsb,_,_)) ->
- failwith "not allowed in the pattern of an isomorphism"
- | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d
- | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) ->
- conjunct_bindings (check_mcode dd d)
- (* hope that mcode of ddots is unique somehow *)
- (let (ddots_whencode_allowed,_,_) = whencode_allowed in
- if ddots_whencode_allowed
- then add_dot_binding dd (Ast0.DeclTag wc)
- else
- (Printf.printf "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Ddots(_,Some _),_) ->
- failwith "whencode not allowed in a pattern1"
-
- | (Ast0.OptDecl(decla),Ast0.OptDecl(declb))
- | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) ->
- match_decl decla declb
- | (_,Ast0.OptDecl(declb))
- | (_,Ast0.UniqueDecl(declb)) ->
- match_decl pattern declb
- | _ -> return false
- else return_false (ContextRequired (Ast0.DeclTag d))
-
- and match_init pattern i =
- match Ast0.unwrap pattern with
- Ast0.MetaInit(name,pure) ->
- add_pure_binding name pure pure_sp_code.V0.combiner_initialiser
- (function ini -> Ast0.InitTag ini)
- i
- | up ->
- if not(checks_needed) or not(context_required) or is_context i
- then
- match (up,Ast0.unwrap i) with
- (Ast0.InitExpr(expa),Ast0.InitExpr(expb)) ->
- match_expr expa expb
- | (Ast0.InitList(lb1,initlista,rb1),Ast0.InitList(lb,initlistb,rb))
- ->
- conjunct_many_bindings
- [check_mcode lb1 lb; check_mcode rb1 rb;
- match_dots match_init no_list do_nolist_match
- initlista initlistb]
- | (Ast0.InitGccExt(designators1,e1,inia),
- Ast0.InitGccExt(designators2,e2,inib)) ->
- conjunct_many_bindings
- [match_list match_designator
- (function _ -> false) (function _ -> failwith "")
- designators1 designators2;
- check_mcode e1 e2;
- match_init inia inib]
- | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) ->
- conjunct_many_bindings
- [check_mcode c1 c; match_ident namea nameb;
- match_init inia inib]
- | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c
- | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d
- | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) ->
- conjunct_bindings (check_mcode id d)
- (* hope that mcode of edots is unique somehow *)
- (let (_,idots_whencode_allowed,_) = whencode_allowed in
- if idots_whencode_allowed
- then add_dot_binding id (Ast0.InitTag wc)
- else
- (Printf.printf
- "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Idots(_,Some _),_) ->
- failwith "whencode not allowed in a pattern2"
- | (Ast0.OptIni(ia),Ast0.OptIni(ib))
- | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib
- | (_,Ast0.OptIni(ib))
- | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib
- | _ -> return false
- else return_false (ContextRequired (Ast0.InitTag i))
-
- and match_designator pattern d =
- match (pattern,d) with
- (Ast0.DesignatorField(dota,ida),Ast0.DesignatorField(dotb,idb)) ->
- conjunct_bindings (check_mcode dota dotb) (match_ident ida idb)
- | (Ast0.DesignatorIndex(lba,expa,rba),
- Ast0.DesignatorIndex(lbb,expb,rbb)) ->
- conjunct_many_bindings
- [check_mcode lba lbb; match_expr expa expb;
- check_mcode rba rbb]
- | (Ast0.DesignatorRange(lba,mina,dotsa,maxa,rba),
- Ast0.DesignatorRange(lbb,minb,dotsb,maxb,rbb)) ->
- conjunct_many_bindings
- [check_mcode lba lbb; match_expr mina minb;
- check_mcode dotsa dotsb; match_expr maxa maxb;
- check_mcode rba rbb]
- | _ -> return false
-
- and match_param pattern p =
- match Ast0.unwrap pattern with
- Ast0.MetaParam(name,pure) ->
- add_pure_binding name pure pure_sp_code.V0.combiner_parameter
- (function p -> Ast0.ParamTag p)
- p
- | Ast0.MetaParamList(name,_,pure) -> failwith "metaparamlist not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context p
- then
- match (up,Ast0.unwrap p) with
- (Ast0.VoidParam(tya),Ast0.VoidParam(tyb)) -> match_typeC tya tyb
- | (Ast0.Param(tya,ida),Ast0.Param(tyb,idb)) ->
- conjunct_bindings (match_typeC tya tyb)
- (match_option match_ident ida idb)
- | (Ast0.PComma(c1),Ast0.PComma(c)) -> check_mcode c1 c
- | (Ast0.Pdots(d1),Ast0.Pdots(d))
- | (Ast0.Pcircles(d1),Ast0.Pcircles(d)) -> check_mcode d1 d
- | (Ast0.OptParam(parama),Ast0.OptParam(paramb))
- | (Ast0.UniqueParam(parama),Ast0.UniqueParam(paramb)) ->
- match_param parama paramb
- | (_,Ast0.OptParam(paramb))
- | (_,Ast0.UniqueParam(paramb)) -> match_param pattern paramb
- | _ -> return false
- else return_false (ContextRequired (Ast0.ParamTag p))
-
- and match_statement pattern s =
- match Ast0.unwrap pattern with
- Ast0.MetaStmt(name,pure) ->
- (match Ast0.unwrap s with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) ->
- return false (* ... is not a single statement *)
- | _ ->
- add_pure_binding name pure pure_sp_code.V0.combiner_statement
- (function ty -> Ast0.StmtTag ty)
- s)
- | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
- | up ->
- if not(checks_needed) or not(context_required) or is_context s
- then
- match (up,Ast0.unwrap s) with
- (Ast0.FunDecl(_,fninfoa,namea,lp1,paramsa,rp1,lb1,bodya,rb1),
- Ast0.FunDecl(_,fninfob,nameb,lp,paramsb,rp,lb,bodyb,rb)) ->
- conjunct_many_bindings
- [check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode lb1 lb; check_mcode rb1 rb;
- match_fninfo fninfoa fninfob; match_ident namea nameb;
- match_dots match_param is_plist_matcher do_plist_match
- paramsa paramsb;
- match_dots match_statement is_slist_matcher do_slist_match
- bodya bodyb]
- | (Ast0.Decl(_,decla),Ast0.Decl(_,declb)) ->
- match_decl decla declb
- | (Ast0.Seq(lb1,bodya,rb1),Ast0.Seq(lb,bodyb,rb)) ->
- (* seqs can only match if they are all minus (plus code
- allowed) or all context (plus code not allowed in the body).
- we could be more permissive if the expansions of the isos are
- also all seqs, but this would be hard to check except at top
- level, and perhaps not worth checking even in that case.
- Overall, the issue is that braces are used where single
- statements are required, and something not satisfying these
- conditions can cause a single statement to become a
- non-single statement after the transformation.
-
- example: if { ... -foo(); ... }
- if we let the sequence convert to just -foo();
- then we produce invalid code. For some reason,
- single_statement can't deal with this case, perhaps because
- it starts introducing too many braces? don't remember the
- exact problem...
- *)
- conjunct_bindings (check_mcode lb1 lb)
- (conjunct_bindings (check_mcode rb1 rb)
- (if not(checks_needed) or is_minus s or
- (is_context s &&
- List.for_all is_pure_context (Ast0.undots bodyb))
- then
- match_dots match_statement is_slist_matcher do_slist_match
- bodya bodyb
- else return_false (Braces(s))))
- | (Ast0.ExprStatement(expa,sc1),Ast0.ExprStatement(expb,sc)) ->
- conjunct_bindings (check_mcode sc1 sc) (match_expr expa expb)
- | (Ast0.IfThen(if1,lp1,expa,rp1,branch1a,_),
- Ast0.IfThen(if2,lp2,expb,rp2,branch1b,_)) ->
- conjunct_many_bindings
- [check_mcode if1 if2; check_mcode lp1 lp2;
- check_mcode rp1 rp2;
- match_expr expa expb;
- match_statement branch1a branch1b]
- | (Ast0.IfThenElse(if1,lp1,expa,rp1,branch1a,e1,branch2a,_),
- Ast0.IfThenElse(if2,lp2,expb,rp2,branch1b,e2,branch2b,_)) ->
- conjunct_many_bindings
- [check_mcode if1 if2; check_mcode lp1 lp2;
- check_mcode rp1 rp2; check_mcode e1 e2;
- match_expr expa expb;
- match_statement branch1a branch1b;
- match_statement branch2a branch2b]
- | (Ast0.While(w1,lp1,expa,rp1,bodya,_),
- Ast0.While(w,lp,expb,rp,bodyb,_)) ->
- conjunct_many_bindings
- [check_mcode w1 w; check_mcode lp1 lp;
- check_mcode rp1 rp; match_expr expa expb;
- match_statement bodya bodyb]
- | (Ast0.Do(d1,bodya,w1,lp1,expa,rp1,_),
- Ast0.Do(d,bodyb,w,lp,expb,rp,_)) ->
- conjunct_many_bindings
- [check_mcode d1 d; check_mcode w1 w; check_mcode lp1 lp;
- check_mcode rp1 rp; match_statement bodya bodyb;
- match_expr expa expb]
- | (Ast0.For(f1,lp1,e1a,sc1a,e2a,sc2a,e3a,rp1,bodya,_),
- Ast0.For(f,lp,e1b,sc1b,e2b,sc2b,e3b,rp,bodyb,_)) ->
- conjunct_many_bindings
- [check_mcode f1 f; check_mcode lp1 lp; check_mcode sc1a sc1b;
- check_mcode sc2a sc2b; check_mcode rp1 rp;
- match_option match_expr e1a e1b;
- match_option match_expr e2a e2b;
- match_option match_expr e3a e3b;
- match_statement bodya bodyb]
- | (Ast0.Iterator(nma,lp1,argsa,rp1,bodya,_),
- Ast0.Iterator(nmb,lp,argsb,rp,bodyb,_)) ->
- conjunct_many_bindings
- [match_ident nma nmb;
- check_mcode lp1 lp; check_mcode rp1 rp;
- match_dots match_expr is_elist_matcher do_elist_match
- argsa argsb;
- match_statement bodya bodyb]
- | (Ast0.Switch(s1,lp1,expa,rp1,lb1,casesa,rb1),
- Ast0.Switch(s,lp,expb,rp,lb,casesb,rb)) ->
- conjunct_many_bindings
- [check_mcode s1 s; check_mcode lp1 lp; check_mcode rp1 rp;
- check_mcode lb1 lb; check_mcode rb1 rb;
- match_expr expa expb;
- match_dots match_case_line no_list do_nolist_match
- casesa casesb]
- | (Ast0.Break(b1,sc1),Ast0.Break(b,sc))
- | (Ast0.Continue(b1,sc1),Ast0.Continue(b,sc)) ->
- conjunct_bindings (check_mcode b1 b) (check_mcode sc1 sc)
- | (Ast0.Label(l1,c1),Ast0.Label(l2,c)) ->
- conjunct_bindings (match_ident l1 l2) (check_mcode c1 c)
- | (Ast0.Goto(g1,l1,sc1),Ast0.Goto(g,l2,sc)) ->
- conjunct_many_bindings
- [check_mcode g1 g; check_mcode sc1 sc; match_ident l1 l2]
- | (Ast0.Return(r1,sc1),Ast0.Return(r,sc)) ->
- conjunct_bindings (check_mcode r1 r) (check_mcode sc1 sc)
- | (Ast0.ReturnExpr(r1,expa,sc1),Ast0.ReturnExpr(r,expb,sc)) ->
- conjunct_many_bindings
- [check_mcode r1 r; check_mcode sc1 sc; match_expr expa expb]
- | (Ast0.Disj(_,statement_dots_lista,_,_),_) ->
- failwith "disj not supported in patterns"
- | (Ast0.Nest(_,stmt_dotsa,_,_,_),_) ->
- failwith "nest not supported in patterns"
- | (Ast0.Exp(expa),Ast0.Exp(expb)) -> match_expr expa expb
- | (Ast0.TopExp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
- | (Ast0.Exp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
- | (Ast0.TopInit(inita),Ast0.TopInit(initb)) -> match_init inita initb
- | (Ast0.Ty(tya),Ast0.Ty(tyb)) -> match_typeC tya tyb
- | (Ast0.Dots(d,[]),Ast0.Dots(d1,wc))
- | (Ast0.Circles(d,[]),Ast0.Circles(d1,wc))
- | (Ast0.Stars(d,[]),Ast0.Stars(d1,wc)) ->
- (match wc with
- [] -> check_mcode d d1
- | _ ->
- let (_,_,dots_whencode_allowed) = whencode_allowed in
- if dots_whencode_allowed
- then
- conjunct_bindings (check_mcode d d1)
- (List.fold_left
- (function prev ->
- function
- | Ast0.WhenNot wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.DotsStmtTag wc))
- | Ast0.WhenAlways wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d (Ast0.StmtTag wc))
- | Ast0.WhenNotTrue wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.IsoWhenTTag wc))
- | Ast0.WhenNotFalse wc ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.IsoWhenFTag wc))
- | Ast0.WhenModifier(x) ->
- conjunct_bindings prev
- (add_multi_dot_binding d
- (Ast0.IsoWhenTag x)))
- (return true) wc)
- else
- (Printf.printf
- "warning: not applying iso because of whencode";
- return false))
- | (Ast0.Dots(_,_::_),_) | (Ast0.Circles(_,_::_),_)
- | (Ast0.Stars(_,_::_),_) ->
- failwith "whencode not allowed in a pattern3"
- | (Ast0.OptStm(rea),Ast0.OptStm(reb))
- | (Ast0.UniqueStm(rea),Ast0.UniqueStm(reb)) ->
- match_statement rea reb
- | (_,Ast0.OptStm(reb))
- | (_,Ast0.UniqueStm(reb)) -> match_statement pattern reb
- | _ -> return false
- else return_false (ContextRequired (Ast0.StmtTag s))
-
- (* first should provide a subset of the information in the second *)
- and match_fninfo patterninfo cinfo =
- let patterninfo = List.sort compare patterninfo in
- let cinfo = List.sort compare cinfo in
- let rec loop = function
- (Ast0.FStorage(sta)::resta,Ast0.FStorage(stb)::restb) ->
- if mcode_equal sta stb
- then conjunct_bindings (check_mcode sta stb) (loop (resta,restb))
- else return false
- | (Ast0.FType(tya)::resta,Ast0.FType(tyb)::restb) ->
- conjunct_bindings (match_typeC tya tyb) (loop (resta,restb))
- | (Ast0.FInline(ia)::resta,Ast0.FInline(ib)::restb) ->
- if mcode_equal ia ib
- then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
- else return false
- | (Ast0.FAttr(ia)::resta,Ast0.FAttr(ib)::restb) ->
- if mcode_equal ia ib
- then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
- else return false
- | (x::resta,((y::_) as restb)) ->
- (match compare x y with
- -1 -> return false
- | 1 -> loop (resta,restb)
- | _ -> failwith "not possible")
- | _ -> return false in
- loop (patterninfo,cinfo)
-
- and match_case_line pattern c =
- if not(checks_needed) or not(context_required) or is_context c
- then
- match (Ast0.unwrap pattern,Ast0.unwrap c) with
- (Ast0.Default(d1,c1,codea),Ast0.Default(d,c,codeb)) ->
- conjunct_many_bindings
- [check_mcode d1 d; check_mcode c1 c;
- match_dots match_statement is_slist_matcher do_slist_match
- codea codeb]
- | (Ast0.Case(ca1,expa,c1,codea),Ast0.Case(ca,expb,c,codeb)) ->
- conjunct_many_bindings
- [check_mcode ca1 ca; check_mcode c1 c; match_expr expa expb;
- match_dots match_statement is_slist_matcher do_slist_match
- codea codeb]
- | (Ast0.OptCase(ca),Ast0.OptCase(cb)) -> match_case_line ca cb
- | (_,Ast0.OptCase(cb)) -> match_case_line pattern cb
- | _ -> return false
- else return_false (ContextRequired (Ast0.CaseLineTag c)) in
-
- let match_statement_dots x y =
- match_dots match_statement is_slist_matcher do_slist_match x y in
-
- (match_expr, match_decl, match_statement, match_typeC,
- match_statement_dots)
-
-let match_expr dochecks context_required whencode_allowed =
- let (fn,_,_,_,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_decl dochecks context_required whencode_allowed =
- let (_,fn,_,_,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_statement dochecks context_required whencode_allowed =
- let (_,_,fn,_,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_typeC dochecks context_required whencode_allowed =
- let (_,_,_,fn,_) = match_maker dochecks context_required whencode_allowed in
- fn
-
-let match_statement_dots dochecks context_required whencode_allowed =
- let (_,_,_,_,fn) = match_maker dochecks context_required whencode_allowed in
- fn
-
-(* --------------------------------------------------------------------- *)
-(* make an entire tree MINUS *)
-
-let make_minus =
- let mcode (term,arity,info,mcodekind,pos) =
- let new_mcodekind =
- match mcodekind with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) -> Ast0.MINUS(ref([],Ast0.default_token_info))
- | _ -> failwith "make_minus: unexpected befaft")
- | Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *)
- | _ -> failwith "make_minus mcode: unexpected mcodekind" in
- (term,arity,info,new_mcodekind,pos) in
-
- let update_mc mcodekind e =
- match !mcodekind with
- Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) ->
- mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info))
- | _ -> failwith "make_minus: unexpected befaft")
- | Ast0.MINUS(_mc) -> () (* in the part copied from the src term *)
- | Ast0.PLUS -> failwith "make_minus donothing: unexpected plus mcodekind"
- | _ -> failwith "make_minus donothing: unexpected mcodekind" in
-
- let donothing r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- let e = k e in update_mc mcodekind e; e in
-
- (* special case for whencode, because it isn't processed by contextneg,
- since it doesn't appear in the + code *)
- (* cases for dots and nests *)
- let expression r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Edots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Edots(mcode d,whencode))
- | Ast0.Ecircles(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Ecircles(mcode d,whencode))
- | Ast0.Estars(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Estars(mcode d,whencode))
- | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
- update_mc mcodekind e;
- Ast0.rewrap e
- (Ast0.NestExpr(mcode starter,
- r.V0.rebuilder_expression_dots expr_dots,
- mcode ender,whencode,multi))
- | _ -> donothing r k e in
-
- let declaration r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Ddots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Ddots(mcode d,whencode))
- | _ -> donothing r k e in
-
- let statement r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Dots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Dots(mcode d,whencode))
- | Ast0.Circles(d,whencode) ->
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Circles(mcode d,whencode))
- | Ast0.Stars(d,whencode) ->
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Stars(mcode d,whencode))
- | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) ->
- update_mc mcodekind e;
- Ast0.rewrap e
- (Ast0.Nest(mcode starter,r.V0.rebuilder_statement_dots stmt_dots,
- mcode ender,whencode,multi))
- | _ -> donothing r k e in
-
- let initialiser r k e =
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.Idots(d,whencode) ->
- (*don't recurse because whencode hasn't been processed by context_neg*)
- update_mc mcodekind e; Ast0.rewrap e (Ast0.Idots(mcode d,whencode))
- | _ -> donothing r k e in
-
- let dots r k e =
- let info = Ast0.get_info e in
- let mcodekind = Ast0.get_mcodekind_ref e in
- match Ast0.unwrap e with
- Ast0.DOTS([]) ->
- (* if context is - this should be - as well. There are no tokens
- here though, so the bottom-up minusifier in context_neg leaves it
- as mixed (or context for sgrep2). It would be better to fix
- context_neg, but that would
- require a special case for each term with a dots subterm. *)
- (match !mcodekind with
- Ast0.MIXED(mc) | Ast0.CONTEXT(mc) ->
- (match !mc with
- (Ast.NOTHING,_,_) ->
- mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info));
- e
- | _ -> failwith "make_minus: unexpected befaft")
- (* code already processed by an enclosing iso *)
- | Ast0.MINUS(mc) -> e
- | _ ->
- failwith
- (Printf.sprintf
- "%d: make_minus donothingxxx: unexpected mcodekind: %s"
- info.Ast0.line_start (Dumper.dump e)))
- | _ -> donothing r k e in
-
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- dots dots dots dots dots dots
- donothing expression donothing initialiser donothing declaration
- statement donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* rebuild mcode cells in an instantiated alt *)
-
-(* mcodes will be side effected later with plus code, so we have to copy
- them on instantiating an isomorphism. One could wonder whether it would
- be better not to use side-effects, but they are convenient for insert_plus
- where is it useful to manipulate a list of the mcodes but side-effect a
- tree *)
-(* hmm... Insert_plus is called before Iso_pattern... *)
-let rebuild_mcode start_line =
- let copy_mcodekind = function
- Ast0.CONTEXT(mc) -> Ast0.CONTEXT(ref (!mc))
- | Ast0.MINUS(mc) -> Ast0.MINUS(ref (!mc))
- | Ast0.MIXED(mc) -> Ast0.MIXED(ref (!mc))
- | Ast0.PLUS ->
- (* this function is used elsewhere where we need to rebuild the
- indices, and so we allow PLUS code as well *)
- Ast0.PLUS in
-
- let mcode (term,arity,info,mcodekind,pos) =
- let info =
- match start_line with
- Some x -> {info with Ast0.line_start = x; Ast0.line_end = x}
- | None -> info in
- (term,arity,info,copy_mcodekind mcodekind,pos) in
-
- let copy_one x =
- let old_info = Ast0.get_info x in
- let info =
- match start_line with
- Some x -> {old_info with Ast0.line_start = x; Ast0.line_end = x}
- | None -> old_info in
- {x with Ast0.info = info; Ast0.index = ref(Ast0.get_index x);
- Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind x))} in
-
- let donothing r k e = copy_one (k e) in
-
- (* case for control operators (if, etc) *)
- let statement r k e =
- let s = k e in
- let res =
- copy_one
- (Ast0.rewrap s
- (match Ast0.unwrap s with
- Ast0.Decl((info,mc),decl) ->
- Ast0.Decl((info,copy_mcodekind mc),decl)
- | Ast0.IfThen(iff,lp,tst,rp,branch,(info,mc)) ->
- Ast0.IfThen(iff,lp,tst,rp,branch,(info,copy_mcodekind mc))
- | Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,(info,mc)) ->
- Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,
- (info,copy_mcodekind mc))
- | Ast0.While(whl,lp,exp,rp,body,(info,mc)) ->
- Ast0.While(whl,lp,exp,rp,body,(info,copy_mcodekind mc))
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,(info,mc)) ->
- Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,
- (info,copy_mcodekind mc))
- | Ast0.Iterator(nm,lp,args,rp,body,(info,mc)) ->
- Ast0.Iterator(nm,lp,args,rp,body,(info,copy_mcodekind mc))
- | Ast0.FunDecl
- ((info,mc),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- Ast0.FunDecl
- ((info,copy_mcodekind mc),
- fninfo,name,lp,params,rp,lbrace,body,rbrace)
- | s -> s)) in
- Ast0.set_dots_bef_aft res
- (match Ast0.get_dots_bef_aft res with
- Ast0.NoDots -> Ast0.NoDots
- | Ast0.AddingBetweenDots s ->
- Ast0.AddingBetweenDots(r.V0.rebuilder_statement s)
- | Ast0.DroppingBetweenDots s ->
- Ast0.DroppingBetweenDots(r.V0.rebuilder_statement s)) in
-
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing
- donothing statement donothing donothing
-
-(* --------------------------------------------------------------------- *)
-(* The problem of whencode. If an isomorphism contains dots in multiple
- rules, then the code that is matched cannot contain whencode, because we
- won't know which dots it goes with. Should worry about nests, but they
- aren't allowed in isomorphisms for the moment. *)
-
-let count_edots =
- let mcode x = 0 in
- let option_default = 0 in
- let bind x y = x + y in
- let donothing r k e = k e in
- let exprfn r k e =
- match Ast0.unwrap e with
- Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> 1
- | _ -> 0 in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing exprfn donothing donothing donothing donothing donothing
- donothing donothing
-
-let count_idots =
- let mcode x = 0 in
- let option_default = 0 in
- let bind x y = x + y in
- let donothing r k e = k e in
- let initfn r k e =
- match Ast0.unwrap e with Ast0.Idots(_,_) -> 1 | _ -> 0 in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing initfn donothing donothing donothing
- donothing donothing
-
-let count_dots =
- let mcode x = 0 in
- let option_default = 0 in
- let bind x y = x + y in
- let donothing r k e = k e in
- let stmtfn r k e =
- match Ast0.unwrap e with
- Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> 1
- | _ -> 0 in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing stmtfn
- donothing donothing
-
-(* --------------------------------------------------------------------- *)
-
-let lookup name bindings mv_bindings =
- try Common.Left (List.assoc (term name) bindings)
- with
- Not_found ->
- (* failure is not possible anymore *)
- Common.Right (List.assoc (term name) mv_bindings)
-
-(* mv_bindings is for the fresh metavariables that are introduced by the
-isomorphism *)
-let instantiate bindings mv_bindings =
- let mcode x =
- match Ast0.get_pos x with
- Ast0.MetaPos(name,_,_) ->
- (try
- match lookup name bindings mv_bindings with
- Common.Left(Ast0.MetaPosTag(id)) -> Ast0.set_pos id x
- | _ -> failwith "not possible"
- with Not_found -> Ast0.set_pos Ast0.NoMetaPos x)
- | _ -> x in
- let donothing r k e = k e in
-
- (* cases where metavariables can occur *)
- let identfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaId(name,constraints,pure) ->
- (rebuild_mcode None).V0.rebuilder_ident
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.IdentTag(id)) -> id
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaId
- (Ast0.set_mcode_data new_mv name,constraints,pure)))
- | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
- | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
- | _ -> e in
-
- (* case for list metavariables *)
- let rec elist r same_dots = function
- [] -> []
- | [x] ->
- (match Ast0.unwrap x with
- Ast0.MetaExprList(name,lenname,pure) ->
- failwith "meta_expr_list in iso not supported"
- (*match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsExprTag(exp)) ->
- (match same_dots exp with
- Some l -> l
- | None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.ExprTag(exp)) -> [exp]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- failwith "MetaExprList in SP not supported"*)
- | _ -> [r.V0.rebuilder_expression x])
- | x::xs -> (r.V0.rebuilder_expression x)::(elist r same_dots xs) in
-
- let rec plist r same_dots = function
- [] -> []
- | [x] ->
- (match Ast0.unwrap x with
- Ast0.MetaParamList(name,lenname,pure) ->
- failwith "meta_param_list in iso not supported"
- (*match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsParamTag(param)) ->
- (match same_dots param with
- Some l -> l
- | None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.ParamTag(param)) -> [param]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- failwith "MetaExprList in SP not supported"*)
- | _ -> [r.V0.rebuilder_parameter x])
- | x::xs -> (r.V0.rebuilder_parameter x)::(plist r same_dots xs) in
-
- let rec slist r same_dots = function
- [] -> []
- | [x] ->
- (match Ast0.unwrap x with
- Ast0.MetaStmtList(name,pure) ->
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.DotsStmtTag(stm)) ->
- (match same_dots stm with
- Some l -> l
- | None -> failwith "dots put in incompatible context")
- | Common.Left(Ast0.StmtTag(stm)) -> [stm]
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- failwith "MetaExprList in SP not supported")
- | _ -> [r.V0.rebuilder_statement x])
- | x::xs -> (r.V0.rebuilder_statement x)::(slist r same_dots xs) in
-
- let same_dots d =
- match Ast0.unwrap d with Ast0.DOTS(l) -> Some l |_ -> None in
- let same_circles d =
- match Ast0.unwrap d with Ast0.CIRCLES(l) -> Some l |_ -> None in
- let same_stars d =
- match Ast0.unwrap d with Ast0.STARS(l) -> Some l |_ -> None in
-
- let dots list_fn r k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(list_fn r same_dots l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(list_fn r same_circles l)
- | Ast0.STARS(l) -> Ast0.STARS(list_fn r same_stars l)) in
-
- let exprfn r k old_e = (* need to keep the original code for ! optim *)
- let e = k old_e in
- let e1 =
- match Ast0.unwrap e with
- Ast0.MetaExpr(name,constraints,x,form,pure) ->
- (rebuild_mcode None).V0.rebuilder_expression
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.ExprTag(exp)) -> exp
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- let new_types =
- match x with
- None -> None
- | Some types ->
- let rec renamer = function
- Type_cocci.MetaType(name,keep,inherited) ->
- (match
- lookup (name,(),(),(),None) bindings mv_bindings
- with
- Common.Left(Ast0.TypeCTag(t)) ->
- Ast0.ast0_type_to_type t
- | Common.Left(_) ->
- failwith "iso pattern: unexpected type"
- | Common.Right(new_mv) ->
- Type_cocci.MetaType(new_mv,keep,inherited))
- | Type_cocci.ConstVol(cv,ty) ->
- Type_cocci.ConstVol(cv,renamer ty)
- | Type_cocci.Pointer(ty) ->
- Type_cocci.Pointer(renamer ty)
- | Type_cocci.FunctionPointer(ty) ->
- Type_cocci.FunctionPointer(renamer ty)
- | Type_cocci.Array(ty) ->
- Type_cocci.Array(renamer ty)
- | t -> t in
- Some(List.map renamer types) in
- Ast0.rewrap e
- (Ast0.MetaExpr
- (Ast0.set_mcode_data new_mv name,constraints,
- new_types,form,pure)))
- | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
- | Ast0.MetaExprList(namea,lenname,pure) ->
- failwith "metaexprlist not supported"
- | Ast0.Unary(exp,unop) ->
- (match Ast0.unwrap_mcode unop with
- Ast.Not ->
- let was_meta =
- (* k e doesn't change the outer structure of the term,
- only the metavars *)
- match Ast0.unwrap old_e with
- Ast0.Unary(exp,_) ->
- (match Ast0.unwrap exp with
- Ast0.MetaExpr(name,constraints,x,form,pure) -> true
- | _ -> false)
- | _ -> failwith "not possible" in
- let nomodif e =
- let mc = Ast0.get_mcodekind exp in
- match mc with
- Ast0.MINUS(x) ->
- (match !x with
- ([],_) -> true
- | _ -> false)
- | Ast0.CONTEXT(x) | Ast0.MIXED(x) ->
- (match !x with
- (Ast.NOTHING,_,_) -> true
- | _ -> false)
- | _ -> failwith "plus not possible" in
- if was_meta && nomodif exp && nomodif e
- then
- let idcont x = x in
- let rec negate e (*for rewrapping*) res (*code to process*) k =
- (* k accumulates parens, to keep negation outside if no
- propagation is possible *)
- match Ast0.unwrap res with
- Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not ->
- k (Ast0.rewrap e (Ast0.unwrap e1))
- | Ast0.Edots(_,_) -> k (Ast0.rewrap e (Ast0.unwrap res))
- | Ast0.Paren(lp,e,rp) ->
- negate e e
- (function x ->
- k (Ast0.rewrap res (Ast0.Paren(lp,x,rp))))
- | Ast0.Binary(e1,op,e2) ->
- let reb nop = Ast0.rewrap_mcode op (Ast.Logical(nop)) in
- let k1 x = k (Ast0.rewrap e x) in
- (match Ast0.unwrap_mcode op with
- Ast.Logical(Ast.Inf) ->
- k1 (Ast0.Binary(e1,reb Ast.SupEq,e2))
- | Ast.Logical(Ast.Sup) ->
- k1 (Ast0.Binary(e1,reb Ast.InfEq,e2))
- | Ast.Logical(Ast.InfEq) ->
- k1 (Ast0.Binary(e1,reb Ast.Sup,e2))
- | Ast.Logical(Ast.SupEq) ->
- k1 (Ast0.Binary(e1,reb Ast.Inf,e2))
- | Ast.Logical(Ast.Eq) ->
- k1 (Ast0.Binary(e1,reb Ast.NotEq,e2))
- | Ast.Logical(Ast.NotEq) ->
- k1 (Ast0.Binary(e1,reb Ast.Eq,e2))
- | Ast.Logical(Ast.AndLog) ->
- k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.OrLog,
- negate e2 e2 idcont))
- | Ast.Logical(Ast.OrLog) ->
- k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.AndLog,
- negate e2 e2 idcont))
- | _ ->
- Ast0.rewrap e
- (Ast0.Unary(k res,Ast0.rewrap_mcode op Ast.Not)))
- | Ast0.DisjExpr(lp,exps,mids,rp) ->
- (* use res because it is the transformed argument *)
- let exps = List.map (function e -> negate e e k) exps in
- Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp))
- | _ ->
- (*use e, because this might be the toplevel expression*)
- Ast0.rewrap e
- (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not)) in
- negate e exp idcont
- else e
- | _ -> e)
- | Ast0.Edots(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Edots(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | Ast0.Ecircles(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Ecircles(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | Ast0.Estars(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Estars(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | _ -> e in
- if Ast0.get_test_exp old_e then Ast0.set_test_exp e1 else e1 in
-
- let tyfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaType(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_typeC
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.TypeCTag(ty)) -> ty
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaType(Ast0.set_mcode_data new_mv name,pure)))
- | _ -> e in
-
- let initfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaInit(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_initialiser
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.InitTag(ty)) -> ty
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaInit(Ast0.set_mcode_data new_mv name,pure)))
- | _ -> e in
-
- let declfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.Ddots(d,_) ->
- (try
- (match List.assoc (dot_term d) bindings with
- Ast0.DeclTag(exp) -> Ast0.rewrap e (Ast0.Ddots(d,Some exp))
- | _ -> failwith "unexpected binding")
- with Not_found -> e)
- | _ -> e in
-
- let paramfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaParam(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_parameter
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.ParamTag(param)) -> param
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaParam(Ast0.set_mcode_data new_mv name, pure)))
- | Ast0.MetaParamList(name,lenname,pure) ->
- failwith "metaparamlist not supported"
- | _ -> e in
-
- let whenfn (_,v) =
- match v with
- Ast0.DotsStmtTag(stms) -> Ast0.WhenNot stms
- | Ast0.StmtTag(stm) -> Ast0.WhenAlways stm
- | Ast0.IsoWhenTTag(stm) -> Ast0.WhenNotTrue stm
- | Ast0.IsoWhenFTag(stm) -> Ast0.WhenNotFalse stm
- | Ast0.IsoWhenTag(x) -> Ast0.WhenModifier(x)
- | _ -> failwith "unexpected binding" in
-
- let stmtfn r k e =
- let e = k e in
- match Ast0.unwrap e with
- Ast0.MetaStmt(name,pure) ->
- (rebuild_mcode None).V0.rebuilder_statement
- (match lookup name bindings mv_bindings with
- Common.Left(Ast0.StmtTag(stm)) -> stm
- | Common.Left(_) -> failwith "not possible 1"
- | Common.Right(new_mv) ->
- Ast0.rewrap e
- (Ast0.MetaStmt(Ast0.set_mcode_data new_mv name,pure)))
- | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
- | Ast0.Dots(d,_) ->
- Ast0.rewrap e
- (Ast0.Dots
- (d,
- List.map whenfn
- (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
- | Ast0.Circles(d,_) ->
- Ast0.rewrap e
- (Ast0.Circles
- (d,
- List.map whenfn
- (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
- | Ast0.Stars(d,_) ->
- Ast0.rewrap e
- (Ast0.Stars
- (d,
- List.map whenfn
- (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
- | _ -> e in
-
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- (dots elist) donothing (dots plist) (dots slist) donothing donothing
- identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
-
-(* --------------------------------------------------------------------- *)
-
-let is_minus e =
- match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
-
-let context_required e = not(is_minus e) && not !Flag.sgrep_mode2
-
-let disj_fail bindings e =
- match bindings with
- Some x -> Printf.fprintf stderr "no disj available at this type"; e
- | None -> e
-
-(* isomorphism code is by default CONTEXT *)
-let merge_plus model_mcode e_mcode =
- match model_mcode with
- Ast0.MINUS(mc) ->
- (* add the replacement information at the root *)
- (match e_mcode with
- Ast0.MINUS(emc) ->
- emc :=
- (match (!mc,!emc) with
- (([],_),(x,t)) | ((x,_),([],t)) -> (x,t)
- | _ -> failwith "how can we combine minuses?")
- | _ -> failwith "not possible 6")
- | Ast0.CONTEXT(mc) ->
- (match e_mcode with
- Ast0.CONTEXT(emc) ->
- (* keep the logical line info as in the model *)
- let (mba,tb,ta) = !mc in
- let (eba,_,_) = !emc in
- (* merging may be required when a term is replaced by a subterm *)
- let merged =
- match (mba,eba) with
- (x,Ast.NOTHING) | (Ast.NOTHING,x) -> x
- | (Ast.BEFORE(b1),Ast.BEFORE(b2)) -> Ast.BEFORE(b1@b2)
- | (Ast.BEFORE(b),Ast.AFTER(a)) -> Ast.BEFOREAFTER(b,a)
- | (Ast.BEFORE(b1),Ast.BEFOREAFTER(b2,a)) ->
- Ast.BEFOREAFTER(b1@b2,a)
- | (Ast.AFTER(a),Ast.BEFORE(b)) -> Ast.BEFOREAFTER(b,a)
- | (Ast.AFTER(a1),Ast.AFTER(a2)) ->Ast.AFTER(a2@a1)
- | (Ast.AFTER(a1),Ast.BEFOREAFTER(b,a2)) -> Ast.BEFOREAFTER(b,a2@a1)
- | (Ast.BEFOREAFTER(b1,a),Ast.BEFORE(b2)) ->
- Ast.BEFOREAFTER(b1@b2,a)
- | (Ast.BEFOREAFTER(b,a1),Ast.AFTER(a2)) ->
- Ast.BEFOREAFTER(b,a2@a1)
- | (Ast.BEFOREAFTER(b1,a1),Ast.BEFOREAFTER(b2,a2)) ->
- Ast.BEFOREAFTER(b1@b2,a2@a1) in
- emc := (merged,tb,ta)
- | Ast0.MINUS(emc) ->
- let (anything_bef_aft,_,_) = !mc in
- let (anythings,t) = !emc in
- emc :=
- (match anything_bef_aft with
- Ast.BEFORE(b) -> (b@anythings,t)
- | Ast.AFTER(a) -> (anythings@a,t)
- | Ast.BEFOREAFTER(b,a) -> (b@anythings@a,t)
- | Ast.NOTHING -> (anythings,t))
- | _ -> failwith "not possible 7")
- | Ast0.MIXED(_) -> failwith "not possible 8"
- | Ast0.PLUS -> failwith "not possible 9"
-
-let copy_plus printer minusify model e =
- if !Flag.sgrep_mode2
- then e (* no plus code, can cause a "not possible" error, so just avoid it *)
- else
- let e =
- match Ast0.get_mcodekind model with
- Ast0.MINUS(mc) -> minusify e
- | Ast0.CONTEXT(mc) -> e
- | _ -> failwith "not possible: copy_plus\n" in
- merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e);
- e
-
-let copy_minus printer minusify model e =
- match Ast0.get_mcodekind model with
- Ast0.MINUS(mc) -> minusify e
- | Ast0.CONTEXT(mc) -> e
- | Ast0.MIXED(_) ->
- if !Flag.sgrep_mode2
- then e
- else failwith "not possible 8"
- | Ast0.PLUS -> failwith "not possible 9"
-
-let whencode_allowed prev_ecount prev_icount prev_dcount
- ecount icount dcount rest =
- (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
- won't be tested *)
- let other_ecount = (* number of edots *)
- List.fold_left (function rest -> function (_,ec,ic,dc) -> ec + rest)
- prev_ecount rest in
- let other_icount = (* number of dots *)
- List.fold_left (function rest -> function (_,ec,ic,dc) -> ic + rest)
- prev_icount rest in
- let other_dcount = (* number of dots *)
- List.fold_left (function rest -> function (_,ec,ic,dc) -> dc + rest)
- prev_dcount rest in
- (ecount = 0 or other_ecount = 0, icount = 0 or other_icount = 0,
- dcount = 0 or other_dcount = 0)
-
-(* copy the befores and afters to the instantiated code *)
-let extra_copy_stmt_plus model e =
- (if not !Flag.sgrep_mode2 (* sgrep has no plus code, so nothing to do *)
- then
- (match Ast0.unwrap model with
- Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
- | Ast0.Decl((info,bef),_) ->
- (match Ast0.unwrap e with
- Ast0.FunDecl((info,bef1),_,_,_,_,_,_,_,_)
- | Ast0.Decl((info,bef1),_) ->
- merge_plus bef bef1
- | _ -> merge_plus bef (Ast0.get_mcodekind e))
- | Ast0.IfThen(_,_,_,_,_,(info,aft))
- | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
- | Ast0.While(_,_,_,_,_,(info,aft))
- | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft))
- | Ast0.Iterator(_,_,_,_,_,(info,aft)) ->
- (match Ast0.unwrap e with
- Ast0.IfThen(_,_,_,_,_,(info,aft1))
- | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft1))
- | Ast0.While(_,_,_,_,_,(info,aft1))
- | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft1))
- | Ast0.Iterator(_,_,_,_,_,(info,aft1)) ->
- merge_plus aft aft1
- | _ -> merge_plus aft (Ast0.get_mcodekind e))
- | _ -> ()));
- e
-
-let extra_copy_other_plus model e = e
-
-(* --------------------------------------------------------------------- *)
-
-let mv_count = ref 0
-let new_mv (_,s) =
- let ct = !mv_count in
- mv_count := !mv_count + 1;
- "_"^s^"_"^(string_of_int ct)
-
-let get_name = function
- Ast.MetaIdDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaIdDecl(ar,nm))
- | Ast.MetaFreshIdDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaFreshIdDecl(ar,nm))
- | Ast.MetaTypeDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaTypeDecl(ar,nm))
- | Ast.MetaInitDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaInitDecl(ar,nm))
- | Ast.MetaListlenDecl(nm) ->
- failwith "should not be rebuilt"
- | Ast.MetaParamDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaParamDecl(ar,nm))
- | Ast.MetaParamListDecl(ar,nm,nm1) ->
- (nm,function nm -> Ast.MetaParamListDecl(ar,nm,nm1))
- | Ast.MetaConstDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaConstDecl(ar,nm,ty))
- | Ast.MetaErrDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaErrDecl(ar,nm))
- | Ast.MetaExpDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaExpDecl(ar,nm,ty))
- | Ast.MetaIdExpDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaIdExpDecl(ar,nm,ty))
- | Ast.MetaLocalIdExpDecl(ar,nm,ty) ->
- (nm,function nm -> Ast.MetaLocalIdExpDecl(ar,nm,ty))
- | Ast.MetaExpListDecl(ar,nm,nm1) ->
- (nm,function nm -> Ast.MetaExpListDecl(ar,nm,nm1))
- | Ast.MetaStmDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaStmDecl(ar,nm))
- | Ast.MetaStmListDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaStmListDecl(ar,nm))
- | Ast.MetaFuncDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaFuncDecl(ar,nm))
- | Ast.MetaLocalFuncDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaLocalFuncDecl(ar,nm))
- | Ast.MetaPosDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaPosDecl(ar,nm))
- | Ast.MetaDeclarerDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaDeclarerDecl(ar,nm))
- | Ast.MetaIteratorDecl(ar,nm) ->
- (nm,function nm -> Ast.MetaIteratorDecl(ar,nm))
-
-let make_new_metavars metavars bindings =
- let new_metavars =
- List.filter
- (function mv ->
- let (s,_) = get_name mv in
- try let _ = List.assoc s bindings in false with Not_found -> true)
- metavars in
- List.split
- (List.map
- (function mv ->
- let (s,rebuild) = get_name mv in
- let new_s = (!current_rule,new_mv s) in
- (rebuild new_s, (s,new_s)))
- new_metavars)
-
-(* --------------------------------------------------------------------- *)
-
-let do_nothing x = x
-
-let mkdisj matcher metavars alts e instantiater mkiso disj_maker minusify
- rebuild_mcodes name printer extra_plus update_others =
- let call_instantiate bindings mv_bindings alts =
- List.concat
- (List.map
- (function (a,_,_,_) ->
- nub
- (* no need to create duplicates when the bindings have no effect *)
- (List.map
- (function bindings ->
- Ast0.set_iso
- (copy_plus printer minusify e
- (extra_plus e
- (instantiater bindings mv_bindings
- (rebuild_mcodes a))))
- (Common.union_set [(name,mkiso a)] (Ast0.get_iso e)))
- bindings))
- alts) in
- let rec inner_loop all_alts prev_ecount prev_icount prev_dcount = function
- [] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
- | ((pattern,ecount,icount,dcount)::rest) ->
- let wc =
- whencode_allowed prev_ecount prev_icount prev_dcount
- ecount dcount icount rest in
- (match matcher true (context_required e) wc pattern e init_env with
- Fail(reason) ->
- if reason = NonMatch || not !Flag_parsing_cocci.show_iso_failures
- then ()
- else
- (match matcher false false wc pattern e init_env with
- OK _ ->
- interpret_reason name (Ast0.get_line e) reason
- (function () -> printer e)
- | _ -> ());
- inner_loop all_alts (prev_ecount + ecount) (prev_icount + icount)
- (prev_dcount + dcount) rest
- | OK (bindings : (((string * string) * 'a) list list)) ->
- let all_alts =
- (* apply update_others to all patterns other than the matched
- one. This is used to desigate the others as test
- expressions in the TestExpression case *)
- (List.map
- (function (x,e,i,d) as all ->
- if x = pattern
- then all
- else (update_others x,e,i,d))
- (List.hd all_alts)) ::
- (List.map
- (List.map (function (x,e,i,d) -> (update_others x,e,i,d)))
- (List.tl all_alts)) in
- (match List.concat all_alts with
- [x] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
- | all_alts ->
- let (new_metavars,mv_bindings) =
- make_new_metavars metavars (nub(List.concat bindings)) in
- Common.Right
- (new_metavars,
- call_instantiate bindings mv_bindings all_alts))) in
- let rec outer_loop prev_ecount prev_icount prev_dcount = function
- [] | [[_]] (*only one alternative*) -> ([],e) (* nothing matched *)
- | (alts::rest) as all_alts ->
- match inner_loop all_alts prev_ecount prev_icount prev_dcount alts with
- Common.Left(prev_ecount, prev_icount, prev_dcount) ->
- outer_loop prev_ecount prev_icount prev_dcount rest
- | Common.Right (new_metavars,res) ->
- (new_metavars,
- copy_minus printer minusify e (disj_maker res)) in
- outer_loop 0 0 0 alts
-
-(* no one should ever look at the information stored in these mcodes *)
-let disj_starter lst =
- let old_info = Ast0.get_info(List.hd lst) in
- let info =
- { old_info with
- Ast0.line_end = old_info.Ast0.line_start;
- Ast0.logical_end = old_info.Ast0.logical_start;
- Ast0.attachable_start = false; Ast0.attachable_end = false;
- Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.strings_before = []; Ast0.strings_after = [] } in
- Ast0.make_mcode_info "(" info
-
-let disj_ender lst =
- let old_info = Ast0.get_info(List.hd lst) in
- let info =
- { old_info with
- Ast0.line_start = old_info.Ast0.line_end;
- Ast0.logical_start = old_info.Ast0.logical_end;
- Ast0.attachable_start = false; Ast0.attachable_end = false;
- Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.strings_before = []; Ast0.strings_after = [] } in
- Ast0.make_mcode_info ")" info
-
-let disj_mid _ = Ast0.make_mcode "|"
-
-let make_disj_type tl =
- let mids =
- match tl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap (Ast0.DisjType(disj_starter tl,tl,mids,disj_ender tl))
-let make_disj_stmt_list tl =
- let mids =
- match tl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap (Ast0.Disj(disj_starter tl,tl,mids,disj_ender tl))
-let make_disj_expr model el =
- let mids =
- match el with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- let update_arg x =
- if Ast0.get_arg_exp model then Ast0.set_arg_exp x else x in
- let update_test x =
- let x = if Ast0.get_test_pos model then Ast0.set_test_pos x else x in
- if Ast0.get_test_exp model then Ast0.set_test_exp x else x in
- let el = List.map update_arg (List.map update_test el) in
- Ast0.context_wrap (Ast0.DisjExpr(disj_starter el,el,mids,disj_ender el))
-let make_disj_decl dl =
- let mids =
- match dl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap (Ast0.DisjDecl(disj_starter dl,dl,mids,disj_ender dl))
-let make_disj_stmt sl =
- let dotify x = Ast0.context_wrap (Ast0.DOTS[x]) in
- let mids =
- match sl with
- [] -> failwith "bad disjunction"
- | x::xs -> List.map disj_mid xs in
- Ast0.context_wrap
- (Ast0.Disj(disj_starter sl,List.map dotify sl,mids,disj_ender sl))
-
-let transform_type (metavars,alts,name) e =
- match alts with
- (Ast0.TypeCTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
- let alts =
- List.map
- (List.map
- (function
- Ast0.TypeCTag(p) ->
- (p,count_edots.V0.combiner_typeC p,
- count_idots.V0.combiner_typeC p,
- count_dots.V0.combiner_typeC p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_typeC metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_typeC)
- (function t -> Ast0.TypeCTag t)
- make_disj_type make_minus.V0.rebuilder_typeC
- (rebuild_mcode start_line).V0.rebuilder_typeC
- name Unparse_ast0.typeC extra_copy_other_plus do_nothing
- | _ -> ([],e)
-
-
-let transform_expr (metavars,alts,name) e =
- let process update_others =
- (* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
- let alts =
- List.map
- (List.map
- (function
- Ast0.ExprTag(p) | Ast0.ArgExprTag(p) | Ast0.TestExprTag(p) ->
- (p,count_edots.V0.combiner_expression p,
- count_idots.V0.combiner_expression p,
- count_dots.V0.combiner_expression p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_expr metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_expression)
- (function e -> Ast0.ExprTag e)
- (make_disj_expr e)
- make_minus.V0.rebuilder_expression
- (rebuild_mcode start_line).V0.rebuilder_expression
- name Unparse_ast0.expression extra_copy_other_plus update_others in
- match alts with
- (Ast0.ExprTag(_)::_)::_ -> process do_nothing
- | (Ast0.ArgExprTag(_)::_)::_ when Ast0.get_arg_exp e -> process do_nothing
- | (Ast0.TestExprTag(_)::_)::_ when Ast0.get_test_pos e ->
- process Ast0.set_test_exp
- | _ -> ([],e)
-
-let transform_decl (metavars,alts,name) e =
- match alts with
- (Ast0.DeclTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some (Ast0.get_info e).Ast0.line_start in
- let alts =
- List.map
- (List.map
- (function
- Ast0.DeclTag(p) ->
- (p,count_edots.V0.combiner_declaration p,
- count_idots.V0.combiner_declaration p,
- count_dots.V0.combiner_declaration p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_decl metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_declaration)
- (function d -> Ast0.DeclTag d)
- make_disj_decl
- make_minus.V0.rebuilder_declaration
- (rebuild_mcode start_line).V0.rebuilder_declaration
- name Unparse_ast0.declaration extra_copy_other_plus do_nothing
- | _ -> ([],e)
-
-let transform_stmt (metavars,alts,name) e =
- match alts with
- (Ast0.StmtTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some (Ast0.get_info e).Ast0.line_start in
- let alts =
- List.map
- (List.map
- (function
- Ast0.StmtTag(p) ->
- (p,count_edots.V0.combiner_statement p,
- count_idots.V0.combiner_statement p,
- count_dots.V0.combiner_statement p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_statement metavars alts e
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_statement)
- (function s -> Ast0.StmtTag s)
- make_disj_stmt make_minus.V0.rebuilder_statement
- (rebuild_mcode start_line).V0.rebuilder_statement
- name (Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
- | _ -> ([],e)
-
-(* sort of a hack, because there is no disj at top level *)
-let transform_top (metavars,alts,name) e =
- match Ast0.unwrap e with
- Ast0.DECL(declstm) ->
- (try
- let strip alts =
- List.map
- (List.map
- (function
- Ast0.DotsStmtTag(d) ->
- (match Ast0.unwrap d with
- Ast0.DOTS([s]) -> Ast0.StmtTag(s)
- | _ -> raise (Failure ""))
- | _ -> raise (Failure "")))
- alts in
- let (mv,s) = transform_stmt (metavars,strip alts,name) declstm in
- (mv,Ast0.rewrap e (Ast0.DECL(s)))
- with Failure _ -> ([],e))
- | Ast0.CODE(stmts) ->
- let (mv,res) =
- match alts with
- (Ast0.DotsStmtTag(_)::_)::_ ->
- (* start line is given to any leaves in the iso code *)
- let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
- let alts =
- List.map
- (List.map
- (function
- Ast0.DotsStmtTag(p) ->
- (p,count_edots.V0.combiner_statement_dots p,
- count_idots.V0.combiner_statement_dots p,
- count_dots.V0.combiner_statement_dots p)
- | _ -> failwith "invalid alt"))
- alts in
- mkdisj match_statement_dots metavars alts stmts
- (function b -> function mv_b ->
- (instantiate b mv_b).V0.rebuilder_statement_dots)
- (function s -> Ast0.DotsStmtTag s)
- (function x ->
- Ast0.rewrap e (Ast0.DOTS([make_disj_stmt_list x])))
- (function x ->
- make_minus.V0.rebuilder_statement_dots x)
- (rebuild_mcode start_line).V0.rebuilder_statement_dots
- name Unparse_ast0.statement_dots extra_copy_other_plus do_nothing
- | _ -> ([],stmts) in
- (mv,Ast0.rewrap e (Ast0.CODE res))
- | _ -> ([],e)
-
-(* --------------------------------------------------------------------- *)
-
-let transform (alts : isomorphism) t =
- (* the following ugliness is because rebuilder only returns a new term *)
- let extra_meta_decls = ref ([] : Ast_cocci.metavar list) in
- let mcode x = x in
- let donothing r k e = k e in
- let exprfn r k e =
- let (extra_meta,exp) = transform_expr alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- exp in
-
- let declfn r k e =
- let (extra_meta,dec) = transform_decl alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- dec in
-
- let stmtfn r k e =
- let (extra_meta,stm) = transform_stmt alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- stm in
-
- let typefn r k e =
- let continue =
- match Ast0.unwrap e with
- Ast0.Signed(signb,tyb) ->
- (* Hack! How else to prevent iso from applying under an
- unsigned??? *)
- e
- | _ -> k e in
- let (extra_meta,ty) = transform_type alts continue in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- ty in
-
- let topfn r k e =
- let (extra_meta,ty) = transform_top alts (k e) in
- extra_meta_decls := extra_meta @ !extra_meta_decls;
- ty in
-
- let res =
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing exprfn typefn donothing donothing declfn stmtfn
- donothing topfn in
- let res = res.V0.rebuilder_top_level t in
- (!extra_meta_decls,res)
-
-(* --------------------------------------------------------------------- *)
-
-(* should be done by functorizing the parser to use wrap or context_wrap *)
-let rewrap =
- let mcode (x,a,i,mc,pos) = (x,a,i,Ast0.context_befaft(),pos) in
- let donothing r k e = Ast0.context_wrap(Ast0.unwrap(k e)) in
- V0.rebuilder
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing
-
-let rewrap_anything = function
- Ast0.DotsExprTag(d) ->
- Ast0.DotsExprTag(rewrap.V0.rebuilder_expression_dots d)
- | Ast0.DotsInitTag(d) ->
- Ast0.DotsInitTag(rewrap.V0.rebuilder_initialiser_list d)
- | Ast0.DotsParamTag(d) ->
- Ast0.DotsParamTag(rewrap.V0.rebuilder_parameter_list d)
- | Ast0.DotsStmtTag(d) ->
- Ast0.DotsStmtTag(rewrap.V0.rebuilder_statement_dots d)
- | Ast0.DotsDeclTag(d) ->
- Ast0.DotsDeclTag(rewrap.V0.rebuilder_declaration_dots d)
- | Ast0.DotsCaseTag(d) ->
- Ast0.DotsCaseTag(rewrap.V0.rebuilder_case_line_dots d)
- | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.V0.rebuilder_ident d)
- | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.ArgExprTag(d) -> Ast0.ArgExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.TestExprTag(d) -> Ast0.TestExprTag(rewrap.V0.rebuilder_expression d)
- | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.V0.rebuilder_typeC d)
- | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.V0.rebuilder_initialiser d)
- | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.V0.rebuilder_parameter d)
- | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.V0.rebuilder_declaration d)
- | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.V0.rebuilder_statement d)
- | Ast0.CaseLineTag(d) -> Ast0.CaseLineTag(rewrap.V0.rebuilder_case_line d)
- | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.V0.rebuilder_top_level d)
- | Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) ->
- failwith "only for isos within iso phase"
- | Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p)
-
-(* --------------------------------------------------------------------- *)
-
-let apply_isos isos rule rule_name =
- if isos = []
- then ([],rule)
- else
- begin
- current_rule := rule_name;
- let isos =
- List.map
- (function (metavars,iso,name) ->
- (metavars,List.map (List.map rewrap_anything) iso,name))
- isos in
- let (extra_meta,rule) =
- List.split
- (List.map
- (function t ->
- List.fold_left
- (function (extra_meta,t) -> function iso ->
- let (new_extra_meta,t) = transform iso t in
- (new_extra_meta@extra_meta,t))
- ([],t) isos)
- rule) in
- (List.concat extra_meta, Compute_lines.compute_lines rule)
- end
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-{
-open Parser_cocci_menhir
-module D = Data
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module P = Parse_aux
-exception Lexical of string
-let tok = Lexing.lexeme
-
-let line = ref 1
-let logical_line = ref 0
-
-(* ---------------------------------------------------------------------- *)
-(* control codes *)
-
-(* Defined in data.ml
-type line_type = MINUS | OPTMINUS | UNIQUEMINUS | PLUS | CONTEXT | UNIQUE | OPT
-*)
-
-let current_line_type = ref (D.CONTEXT,!line,!logical_line)
-
-let prev_plus = ref false
-let line_start = ref 0 (* offset of the beginning of the line *)
-let get_current_line_type lexbuf =
- let (c,l,ll) = !current_line_type in
- let lex_start = Lexing.lexeme_start lexbuf in
- let preceeding_spaces =
- if !line_start < 0 then 0 else lex_start - !line_start in
- line_start := -1;
- prev_plus := (c = D.PLUS);
- (c,l,ll,lex_start,preceeding_spaces,[],[],Ast0.NoMetaPos)
-let current_line_started = ref false
-let col_zero = ref true
-
-let reset_line lexbuf =
- line := !line + 1;
- current_line_type := (D.CONTEXT,!line,!logical_line);
- current_line_started := false;
- col_zero := true;
- line_start := Lexing.lexeme_start lexbuf + 1
-
-let started_line = ref (-1)
-
-let start_line seen_char =
- current_line_started := true;
- col_zero := false;
- (if seen_char && not(!line = !started_line)
- then
- begin
- started_line := !line;
- logical_line := !logical_line + 1
- end)
-
-let pass_zero _ = col_zero := false
-
-let lexerr s1 s2 = raise (Lexical (Printf.sprintf "%s%s" s1 s2))
-
-let add_current_line_type x =
- match (x,!current_line_type) with
- (D.MINUS,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.MINUS,ln,lln)
- | (D.MINUS,(D.UNIQUE,ln,lln)) ->
- current_line_type := (D.UNIQUEMINUS,ln,lln)
- | (D.MINUS,(D.OPT,ln,lln)) ->
- current_line_type := (D.OPTMINUS,ln,lln)
- | (D.PLUS,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.PLUS,ln,lln)
- | (D.UNIQUE,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.UNIQUE,ln,lln)
- | (D.OPT,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.OPT,ln,lln)
- | _ -> lexerr "invalid control character combination" ""
-
-let check_minus_context_linetype s =
- match !current_line_type with
- (D.PLUS,_,_) -> lexerr "invalid in a + context: " s
- | _ -> ()
-
-let check_context_linetype s =
- match !current_line_type with
- (D.CONTEXT,_,_) -> ()
- | _ -> lexerr "invalid in a nonempty context: " s
-
-let check_plus_linetype s =
- match !current_line_type with
- (D.PLUS,_,_) -> ()
- | _ -> lexerr "invalid in a non + context: " s
-
-let check_arity_context_linetype s =
- match !current_line_type with
- (D.CONTEXT,_,_) | (D.PLUS,_,_) | (D.UNIQUE,_,_) | (D.OPT,_,_) -> ()
- | _ -> lexerr "invalid in a nonempty context: " s
-
-let process_include start finish str =
- (match !current_line_type with
- (D.PLUS,_,_) ->
- (try
- let _ = Str.search_forward (Str.regexp "\\.\\.\\.") str start in
- lexerr "... not allowed in + include" ""
- with Not_found -> ())
- | _ -> ());
- String.sub str (start + 1) (finish - start - 1)
-
-(* ---------------------------------------------------------------------- *)
-type pm = PATCH | MATCH | UNKNOWN
-
-let pm = ref UNKNOWN
-
-let patch_or_match = function
- PATCH ->
- (match !pm with
- MATCH -> lexerr "- or + not allowed in the first column for a match" ""
- | PATCH -> ()
- | UNKNOWN -> Flag.sgrep_mode2 := false; pm := PATCH)
- | MATCH ->
- (match !pm with
- PATCH -> lexerr "* not allowed in the first column for a patch" ""
- | MATCH -> ()
- | UNKNOWN -> Flag.sgrep_mode2 := true; pm := MATCH)
- | _ -> failwith "unexpected argument"
-
-(* ---------------------------------------------------------------------- *)
-(* identifiers, including metavariables *)
-
-let metavariables = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let all_metavariables =
- (Hashtbl.create(100) : (string,(string * (D.clt -> token)) list) Hashtbl.t)
-
-let type_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let declarer_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let iterator_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let rule_names = (Hashtbl.create(100) : (string, unit) Hashtbl.t)
-
-let check_var s linetype =
- let fail _ =
- if (!Data.in_prolog || !Data.in_rule_name) &&
- Str.string_match (Str.regexp "<.*>") s 0
- then TPathIsoFile s
- else
- try (Hashtbl.find metavariables s) linetype
- with Not_found ->
- (try (Hashtbl.find type_names s) linetype
- with Not_found ->
- (try (Hashtbl.find declarer_names s) linetype
- with Not_found ->
- (try (Hashtbl.find iterator_names s) linetype
- with Not_found -> TIdent (s,linetype)))) in
- if !Data.in_meta or !Data.in_rule_name
- then (try Hashtbl.find rule_names s; TRuleName s with Not_found -> fail())
- else fail()
-
-let id_tokens lexbuf =
- let s = tok lexbuf in
- let linetype = get_current_line_type lexbuf in
- let in_rule_name = !Data.in_rule_name in
- let in_meta = !Data.in_meta in
- let in_iso = !Data.in_iso in
- let in_prolog = !Data.in_prolog in
- match s with
- "identifier" when in_meta -> check_arity_context_linetype s; TIdentifier
- | "type" when in_meta -> check_arity_context_linetype s; TType
- | "parameter" when in_meta -> check_arity_context_linetype s; TParameter
- | "constant" when in_meta -> check_arity_context_linetype s; TConstant
- | "generated" when in_rule_name && not (!Flag.make_hrule = None) ->
- check_arity_context_linetype s; TGenerated
- | "expression" when in_meta || in_rule_name ->
- check_arity_context_linetype s; TExpression
- | "idexpression" when in_meta ->
- check_arity_context_linetype s; TIdExpression
- | "statement" when in_meta -> check_arity_context_linetype s; TStatement
- | "function" when in_meta -> check_arity_context_linetype s; TFunction
- | "local" when in_meta -> check_arity_context_linetype s; TLocal
- | "list" when in_meta -> check_arity_context_linetype s; Tlist
- | "fresh" when in_meta -> check_arity_context_linetype s; TFresh
- | "typedef" when in_meta -> check_arity_context_linetype s; TTypedef
- | "declarer" when in_meta -> check_arity_context_linetype s; TDeclarer
- | "iterator" when in_meta -> check_arity_context_linetype s; TIterator
- | "name" when in_meta -> check_arity_context_linetype s; TName
- | "position" when in_meta -> check_arity_context_linetype s; TPosition
- | "any" when in_meta -> check_arity_context_linetype s; TPosAny
- | "pure" when in_meta && in_iso ->
- check_arity_context_linetype s; TPure
- | "context" when in_meta && in_iso ->
- check_arity_context_linetype s; TContext
- | "error" when in_meta -> check_arity_context_linetype s; TError
- | "words" when in_meta -> check_context_linetype s; TWords
-
- | "using" when in_rule_name || in_prolog -> check_context_linetype s; TUsing
- | "disable" when in_rule_name -> check_context_linetype s; TDisable
- | "extends" when in_rule_name -> check_context_linetype s; TExtends
- | "depends" when in_rule_name -> check_context_linetype s; TDepends
- | "on" when in_rule_name -> check_context_linetype s; TOn
- | "ever" when in_rule_name -> check_context_linetype s; TEver
- | "never" when in_rule_name -> check_context_linetype s; TNever
- | "exists" when in_rule_name -> check_context_linetype s; TExists
- | "forall" when in_rule_name -> check_context_linetype s; TForall
- | "reverse" when in_rule_name -> check_context_linetype s; TReverse
- | "script" when in_rule_name -> check_context_linetype s; TScript
-
- | "char" -> Tchar linetype
- | "short" -> Tshort linetype
- | "int" -> Tint linetype
- | "double" -> Tdouble linetype
- | "float" -> Tfloat linetype
- | "long" -> Tlong linetype
- | "void" -> Tvoid linetype
- | "struct" -> Tstruct linetype
- | "union" -> Tunion linetype
- | "enum" -> Tenum linetype
- | "unsigned" -> Tunsigned linetype
- | "signed" -> Tsigned linetype
-
- | "auto" -> Tauto linetype
- | "register" -> Tregister linetype
- | "extern" -> Textern linetype
- | "static" -> Tstatic linetype
- | "inline" -> Tinline linetype
- | "typedef" -> Ttypedef linetype
-
- | "const" -> Tconst linetype
- | "volatile" -> Tvolatile linetype
-
- | "if" -> TIf linetype
- | "else" -> TElse linetype
- | "while" -> TWhile linetype
- | "do" -> TDo linetype
- | "for" -> TFor linetype
- | "switch" -> TSwitch linetype
- | "case" -> TCase linetype
- | "default" -> TDefault linetype
- | "return" -> TReturn linetype
- | "break" -> TBreak linetype
- | "continue" -> TContinue linetype
- | "goto" -> TGoto linetype
-
- | "sizeof" -> TSizeof linetype
-
- | "Expression" -> TIsoExpression
- | "ArgExpression" -> TIsoArgExpression
- | "TestExpression" -> TIsoTestExpression
- | "Statement" -> TIsoStatement
- | "Declaration" -> TIsoDeclaration
- | "Type" -> TIsoType
- | "TopLevel" -> TIsoTopLevel
-
- | s -> check_var s linetype
-
-let mkassign op lexbuf =
- TAssign (Ast.OpAssign op, (get_current_line_type lexbuf))
-
-let init _ =
- line := 1;
- logical_line := 0;
- prev_plus := false;
- line_start := 0;
- current_line_started := false;
- col_zero := true;
- pm := UNKNOWN;
- Data.in_rule_name := false;
- Data.in_meta := false;
- Data.in_prolog := false;
- Data.inheritable_positions := [];
- Hashtbl.clear all_metavariables;
- Hashtbl.clear Data.all_metadecls;
- Hashtbl.clear metavariables;
- Hashtbl.clear type_names;
- Hashtbl.clear rule_names;
- let get_name (_,x) = x in
- Data.add_id_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaId(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_type_meta :=
- (fun name pure ->
- let fn clt = TMetaType(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_param_meta :=
- (function name -> function pure ->
- let fn clt = TMetaParam(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_paramlist_meta :=
- (function name -> function lenname -> function pure ->
- let fn clt = TMetaParamList(name,lenname,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_const_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaConst(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_err_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaErr(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_exp_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaExp(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_idexp_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaIdExp(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_local_idexp_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaLocalIdExp(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_explist_meta :=
- (function name -> function lenname -> function pure ->
- let fn clt = TMetaExpList(name,lenname,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_stm_meta :=
- (function name -> function pure ->
- let fn clt = TMetaStm(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_stmlist_meta :=
- (function name -> function pure ->
- let fn clt = TMetaStmList(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_func_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaFunc(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_local_func_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaLocalFunc(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_iterator_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaIterator(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_declarer_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaDeclarer(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_pos_meta :=
- (fun name constraints any ->
- let fn ((d,ln,_,_,_,_,_,_) as clt) =
- (if d = Data.PLUS
- then
- failwith
- (Printf.sprintf "%d: positions only allowed in minus code" ln));
- TMetaPos(name,constraints,any,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_type_name :=
- (function name ->
- let fn clt = TTypeId(name,clt) in
- Hashtbl.replace type_names name fn);
- Data.add_declarer_name :=
- (function name ->
- let fn clt = TDeclarerId(name,clt) in
- Hashtbl.replace declarer_names name fn);
- Data.add_iterator_name :=
- (function name ->
- let fn clt = TIteratorId(name,clt) in
- Hashtbl.replace iterator_names name fn);
- Data.init_rule := (function _ -> Hashtbl.clear metavariables);
- Data.install_bindings :=
- (function parent ->
- List.iter (function (name,fn) -> Hashtbl.add metavariables name fn)
- (Hashtbl.find all_metavariables parent))
-
-let drop_spaces s =
- let len = String.length s in
- let rec loop n =
- if n = len
- then n
- else
- if List.mem (String.get s n) [' ';'\t']
- then loop (n+1)
- else n in
- let start = loop 0 in
- String.sub s start (len - start)
-}
-
-(* ---------------------------------------------------------------------- *)
-(* tokens *)
-
-let letter = ['A'-'Z' 'a'-'z' '_']
-let digit = ['0'-'9']
-
-let dec = ['0'-'9']
-let oct = ['0'-'7']
-let hex = ['0'-'9' 'a'-'f' 'A'-'F']
-
-let decimal = ('0' | (['1'-'9'] dec*))
-let octal = ['0'] oct+
-let hexa = ("0x" |"0X") hex+
-
-let pent = dec+
-let pfract = dec+
-let sign = ['-' '+']
-let exp = ['e''E'] sign? dec+
-let real = pent exp | ((pent? '.' pfract | pent '.' pfract? ) exp?)
-
-
-rule token = parse
- | [' ' '\t' ]+ { start_line false; token lexbuf }
- | ['\n' '\r' '\011' '\012'] { reset_line lexbuf; token lexbuf }
-
- | "//" [^ '\n']* { start_line false; token lexbuf }
-
- | "@@" { start_line true; TArobArob }
- | "@" { pass_zero();
- if !Data.in_rule_name or not !current_line_started
- then (start_line true; TArob)
- else (check_minus_context_linetype "@"; TPArob) }
-
- | "WHEN" | "when"
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TWhen (get_current_line_type lexbuf) }
-
- | "..."
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TEllipsis (get_current_line_type lexbuf) }
-(*
- | "ooo"
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TCircles (get_current_line_type lexbuf) }
-
- | "***"
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TStars (get_current_line_type lexbuf) }
-*)
- | "<..." { start_line true; check_context_linetype (tok lexbuf);
- TOEllipsis (get_current_line_type lexbuf) }
- | "...>" { start_line true; check_context_linetype (tok lexbuf);
- TCEllipsis (get_current_line_type lexbuf) }
- | "<+..." { start_line true; check_context_linetype (tok lexbuf);
- TPOEllipsis (get_current_line_type lexbuf) }
- | "...+>" { start_line true; check_context_linetype (tok lexbuf);
- TPCEllipsis (get_current_line_type lexbuf) }
-(*
- | "<ooo" { start_line true; check_context_linetype (tok lexbuf);
- TOCircles (get_current_line_type lexbuf) }
- | "ooo>" { start_line true; check_context_linetype (tok lexbuf);
- TCCircles (get_current_line_type lexbuf) }
-
- | "<***" { start_line true; check_context_linetype (tok lexbuf);
- TOStars (get_current_line_type lexbuf) }
- | "***>" { start_line true; check_context_linetype (tok lexbuf);
- TCStars (get_current_line_type lexbuf) }
-*)
- | "-" { pass_zero();
- if !current_line_started
- then (start_line true; TMinus (get_current_line_type lexbuf))
- else (patch_or_match PATCH;
- add_current_line_type D.MINUS; token lexbuf) }
- | "+" { pass_zero();
- if !current_line_started
- then (start_line true; TPlus (get_current_line_type lexbuf))
- else if !Data.in_meta
- then TPlus0
- else (patch_or_match PATCH;
- add_current_line_type D.PLUS; token lexbuf) }
- | "?" { pass_zero();
- if !current_line_started
- then (start_line true; TWhy (get_current_line_type lexbuf))
- else if !Data.in_meta
- then TWhy0
- else (add_current_line_type D.OPT; token lexbuf) }
- | "!" { pass_zero();
- if !current_line_started
- then (start_line true; TBang (get_current_line_type lexbuf))
- else if !Data.in_meta
- then TBang0
- else (add_current_line_type D.UNIQUE; token lexbuf) }
- | "(" { if not !col_zero
- then (start_line true; TOPar (get_current_line_type lexbuf))
- else
- (start_line true; check_context_linetype (tok lexbuf);
- TOPar0 (get_current_line_type lexbuf))}
- | "\\(" { start_line true; TOPar0 (get_current_line_type lexbuf) }
- | "|" { if not (!col_zero)
- then (start_line true; TOr(get_current_line_type lexbuf))
- else (start_line true;
- check_context_linetype (tok lexbuf);
- TMid0 (get_current_line_type lexbuf))}
- | "\\|" { start_line true; TMid0 (get_current_line_type lexbuf) }
- | ")" { if not !col_zero
- then (start_line true; TCPar (get_current_line_type lexbuf))
- else
- (start_line true; check_context_linetype (tok lexbuf);
- TCPar0 (get_current_line_type lexbuf))}
- | "\\)" { start_line true; TCPar0 (get_current_line_type lexbuf) }
-
- | '[' { start_line true; TOCro (get_current_line_type lexbuf) }
- | ']' { start_line true; TCCro (get_current_line_type lexbuf) }
- | '{' { start_line true; TOBrace (get_current_line_type lexbuf) }
- | '}' { start_line true; TCBrace (get_current_line_type lexbuf) }
-
- | "->" { start_line true; TPtrOp (get_current_line_type lexbuf) }
- | '.' { start_line true; TDot (get_current_line_type lexbuf) }
- | ',' { start_line true; TComma (get_current_line_type lexbuf) }
- | ";" { start_line true;
- if !Data.in_meta
- then TMPtVirg (* works better with tokens_all *)
- else TPtVirg (get_current_line_type lexbuf) }
-
-
- | '*' { pass_zero();
- if !current_line_started
- then
- (start_line true; TMul (get_current_line_type lexbuf))
- else
- (patch_or_match MATCH;
- add_current_line_type D.MINUS; token lexbuf) }
- | '/' { start_line true;
- TDmOp (Ast.Div,get_current_line_type lexbuf) }
- | '%' { start_line true;
- TDmOp (Ast.Mod,get_current_line_type lexbuf) }
- | '~' { start_line true; TTilde (get_current_line_type lexbuf) }
-
- | "++" { start_line true; TInc (get_current_line_type lexbuf) }
- | "--" { start_line true; TDec (get_current_line_type lexbuf) }
-
- | "=" { start_line true; TEq (get_current_line_type lexbuf) }
-
- | "-=" { start_line true; mkassign Ast.Minus lexbuf }
- | "+=" { start_line true; mkassign Ast.Plus lexbuf }
-
- | "*=" { start_line true; mkassign Ast.Mul lexbuf }
- | "/=" { start_line true; mkassign Ast.Div lexbuf }
- | "%=" { start_line true; mkassign Ast.Mod lexbuf }
-
- | "&=" { start_line true; mkassign Ast.And lexbuf }
- | "|=" { start_line true; mkassign Ast.Or lexbuf }
- | "^=" { start_line true; mkassign Ast.Xor lexbuf }
-
- | "<<=" { start_line true; mkassign Ast.DecLeft lexbuf }
- | ">>=" { start_line true; mkassign Ast.DecRight lexbuf }
-
- | ":" { start_line true; TDotDot (get_current_line_type lexbuf) }
-
- | "==" { start_line true; TEqEq (get_current_line_type lexbuf) }
- | "!=" { start_line true; TNotEq (get_current_line_type lexbuf) }
- | ">=" { start_line true;
- TLogOp(Ast.SupEq,get_current_line_type lexbuf) }
- | "<=" { start_line true;
- TLogOp(Ast.InfEq,get_current_line_type lexbuf) }
- | "<" { start_line true;
- TLogOp(Ast.Inf,get_current_line_type lexbuf) }
- | ">" { start_line true;
- TLogOp(Ast.Sup,get_current_line_type lexbuf) }
-
- | "&&" { start_line true; TAndLog (get_current_line_type lexbuf) }
- | "||" { start_line true; TOrLog (get_current_line_type lexbuf) }
-
- | ">>" { start_line true;
- TShOp(Ast.DecRight,get_current_line_type lexbuf) }
- | "<<" { start_line true;
- TShOp(Ast.DecLeft,get_current_line_type lexbuf) }
-
- | "&" { start_line true; TAnd (get_current_line_type lexbuf) }
- | "^" { start_line true; TXor(get_current_line_type lexbuf) }
-
- | ( ("#" [' ' '\t']* "define" [' ' '\t']+))
- ( (letter (letter |digit)*) as ident)
- { start_line true;
- let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
- get_current_line_type lexbuf in
- let off = String.length "#define " in
- (* -1 in the code below because the ident is not at the line start *)
- TDefine
- (lt,
- check_var ident
- (arity,line,lline,offset+off,(-1),[],[],Ast0.NoMetaPos)) }
- | ( ("#" [' ' '\t']* "define" [' ' '\t']+))
- ( (letter (letter | digit)*) as ident)
- '('
- { start_line true;
- let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
- get_current_line_type lexbuf in
- let off = String.length "#define " in
- TDefineParam
- (lt,
- check_var ident
- (* why pos here but not above? *)
- (arity,line,lline,offset+off,(-1),strbef,straft,pos),
- offset + off + (String.length ident)) }
- | "#" [' ' '\t']* "include" [' ' '\t']* '"' [^ '"']+ '"'
- { TIncludeL
- (let str = tok lexbuf in
- let start = String.index str '"' in
- let finish = String.rindex str '"' in
- start_line true;
- (process_include start finish str,get_current_line_type lexbuf)) }
- | "#" [' ' '\t']* "include" [' ' '\t']* '<' [^ '>']+ '>'
- { TIncludeNL
- (let str = tok lexbuf in
- let start = String.index str '<' in
- let finish = String.rindex str '>' in
- start_line true;
- (process_include start finish str,get_current_line_type lexbuf)) }
- | "#" [' ' '\t']* "if" [^'\n']*
- | "#" [' ' '\t']* "ifdef" [^'\n']*
- | "#" [' ' '\t']* "ifndef" [^'\n']*
- | "#" [' ' '\t']* "else" [^'\n']*
- | "#" [' ' '\t']* "elif" [^'\n']*
- | "#" [' ' '\t']* "endif" [^'\n']*
- | "#" [' ' '\t']* "error" [^'\n']*
- { start_line true; check_plus_linetype (tok lexbuf);
- TPragma (tok lexbuf) }
- | "---" [^'\n']*
- { (if !current_line_started
- then lexerr "--- must be at the beginning of the line" "");
- start_line true;
- TMinusFile
- (let str = tok lexbuf in
- (drop_spaces(String.sub str 3 (String.length str - 3)),
- (get_current_line_type lexbuf))) }
- | "+++" [^'\n']*
- { (if !current_line_started
- then lexerr "+++ must be at the beginning of the line" "");
- start_line true;
- TPlusFile
- (let str = tok lexbuf in
- (drop_spaces(String.sub str 3 (String.length str - 3)),
- (get_current_line_type lexbuf))) }
-
- | letter (letter | digit)*
- { start_line true; id_tokens lexbuf }
-
- | "'" { start_line true;
- TChar(char lexbuf,get_current_line_type lexbuf) }
- | '"' { start_line true;
- TString(string lexbuf,(get_current_line_type lexbuf)) }
- | (real as x) { start_line true;
- TFloat(x,(get_current_line_type lexbuf)) }
- | ((( decimal | hexa | octal)
- ( ['u' 'U']
- | ['l' 'L']
- | (['l' 'L'] ['u' 'U'])
- | (['u' 'U'] ['l' 'L'])
- | (['u' 'U'] ['l' 'L'] ['l' 'L'])
- | (['l' 'L'] ['l' 'L'])
- )?
- ) as x) { start_line true; TInt(x,(get_current_line_type lexbuf)) }
-
- | "<=>" { TIso }
- | "=>" { TRightIso }
-
- | eof { EOF }
-
- | _ { lexerr "unrecognised symbol, in token rule: " (tok lexbuf) }
-
-
-and char = parse
- | (_ as x) "'" { String.make 1 x }
- | (("\\" (oct | oct oct | oct oct oct)) as x "'") { x }
- | (("\\x" (hex | hex hex)) as x "'") { x }
- | (("\\" (_ as v)) as x "'")
- { (match v with
- | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> ()
- | 'r' -> () | 'f' -> () | 'a' -> ()
- | '\\' -> () | '?' -> () | '\'' -> () | '"' -> ()
- | 'e' -> ()
- | _ -> lexerr "unrecognised symbol: " (tok lexbuf)
- );
- x
- }
- | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
-
-and string = parse
- | '"' { "" }
- | (_ as x) { Common.string_of_char x ^ string lexbuf }
- | ("\\" (oct | oct oct | oct oct oct)) as x { x ^ string lexbuf }
- | ("\\x" (hex | hex hex)) as x { x ^ string lexbuf }
- | ("\\" (_ as v)) as x
- {
- (match v with
- | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> () | 'r' -> ()
- | 'f' -> () | 'a' -> ()
- | '\\' -> () | '?' -> () | '\'' -> () | '"' -> ()
- | 'e' -> ()
- | '\n' -> ()
- | _ -> lexerr "unrecognised symbol:" (tok lexbuf)
- );
- x ^ string lexbuf
- }
- | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-{
-open Parser_cocci_menhir
-module D = Data
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module P = Parse_aux
-exception Lexical of string
-let tok = Lexing.lexeme
-
-let line = ref 1
-let logical_line = ref 0
-
-(* ---------------------------------------------------------------------- *)
-(* control codes *)
-
-(* Defined in data.ml
-type line_type = MINUS | OPTMINUS | UNIQUEMINUS | PLUS | CONTEXT | UNIQUE | OPT
-*)
-
-let current_line_type = ref (D.CONTEXT,!line,!logical_line)
-
-let prev_plus = ref false
-let line_start = ref 0 (* offset of the beginning of the line *)
-let get_current_line_type lexbuf =
- let (c,l,ll) = !current_line_type in
- let lex_start = Lexing.lexeme_start lexbuf in
- let preceeding_spaces =
- if !line_start < 0 then 0 else lex_start - !line_start in
- line_start := -1;
- prev_plus := (c = D.PLUS);
- (c,l,ll,lex_start,preceeding_spaces,[],[],Ast0.NoMetaPos)
-let current_line_started = ref false
-let col_zero = ref true
-
-let reset_line lexbuf =
- line := !line + 1;
- current_line_type := (D.CONTEXT,!line,!logical_line);
- current_line_started := false;
- col_zero := true;
- line_start := Lexing.lexeme_start lexbuf + 1
-
-let started_line = ref (-1)
-
-let start_line seen_char =
- current_line_started := true;
- col_zero := false;
- (if seen_char && not(!line = !started_line)
- then
- begin
- started_line := !line;
- logical_line := !logical_line + 1
- end)
-
-let pass_zero _ = col_zero := false
-
-let lexerr s1 s2 = raise (Lexical (Printf.sprintf "%s%s" s1 s2))
-
-let add_current_line_type x =
- match (x,!current_line_type) with
- (D.MINUS,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.MINUS,ln,lln)
- | (D.MINUS,(D.UNIQUE,ln,lln)) ->
- current_line_type := (D.UNIQUEMINUS,ln,lln)
- | (D.MINUS,(D.OPT,ln,lln)) ->
- current_line_type := (D.OPTMINUS,ln,lln)
- | (D.PLUS,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.PLUS,ln,lln)
- | (D.UNIQUE,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.UNIQUE,ln,lln)
- | (D.OPT,(D.CONTEXT,ln,lln)) ->
- current_line_type := (D.OPT,ln,lln)
- | _ -> lexerr "invalid control character combination" ""
-
-let check_minus_context_linetype s =
- match !current_line_type with
- (D.PLUS,_,_) -> lexerr "invalid in a + context: " s
- | _ -> ()
-
-let check_context_linetype s =
- match !current_line_type with
- (D.CONTEXT,_,_) -> ()
- | _ -> lexerr "invalid in a nonempty context: " s
-
-let check_plus_linetype s =
- match !current_line_type with
- (D.PLUS,_,_) -> ()
- | _ -> lexerr "invalid in a non + context: " s
-
-let check_arity_context_linetype s =
- match !current_line_type with
- (D.CONTEXT,_,_) | (D.PLUS,_,_) | (D.UNIQUE,_,_) | (D.OPT,_,_) -> ()
- | _ -> lexerr "invalid in a nonempty context: " s
-
-let process_include start finish str =
- (match !current_line_type with
- (D.PLUS,_,_) ->
- (try
- let _ = Str.search_forward (Str.regexp "\\.\\.\\.") str start in
- lexerr "... not allowed in + include" ""
- with Not_found -> ())
- | _ -> ());
- String.sub str (start + 1) (finish - start - 1)
-
-(* ---------------------------------------------------------------------- *)
-type pm = PATCH | MATCH | UNKNOWN
-
-let pm = ref UNKNOWN
-
-let patch_or_match = function
- PATCH ->
- (match !pm with
- MATCH -> lexerr "- or + not allowed in the first column for a match" ""
- | PATCH -> ()
- | UNKNOWN -> Flag.sgrep_mode2 := false; pm := PATCH)
- | MATCH ->
- (match !pm with
- PATCH -> lexerr "* not allowed in the first column for a patch" ""
- | MATCH -> ()
- | UNKNOWN -> Flag.sgrep_mode2 := true; pm := MATCH)
- | _ -> failwith "unexpected argument"
-
-(* ---------------------------------------------------------------------- *)
-(* identifiers, including metavariables *)
-
-let metavariables = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let all_metavariables =
- (Hashtbl.create(100) : (string,(string * (D.clt -> token)) list) Hashtbl.t)
-
-let type_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let declarer_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let iterator_names = (Hashtbl.create(100) : (string, D.clt -> token) Hashtbl.t)
-
-let rule_names = (Hashtbl.create(100) : (string, unit) Hashtbl.t)
-
-let check_var s linetype =
- let fail _ =
- if (!Data.in_prolog || !Data.in_rule_name) &&
- Str.string_match (Str.regexp "<.*>") s 0
- then TPathIsoFile s
- else
- try (Hashtbl.find metavariables s) linetype
- with Not_found ->
- (try (Hashtbl.find type_names s) linetype
- with Not_found ->
- (try (Hashtbl.find declarer_names s) linetype
- with Not_found ->
- (try (Hashtbl.find iterator_names s) linetype
- with Not_found -> TIdent (s,linetype)))) in
- if !Data.in_meta or !Data.in_rule_name
- then (try Hashtbl.find rule_names s; TRuleName s with Not_found -> fail())
- else fail()
-
-let id_tokens lexbuf =
- let s = tok lexbuf in
- let linetype = get_current_line_type lexbuf in
- let in_rule_name = !Data.in_rule_name in
- let in_meta = !Data.in_meta in
- let in_iso = !Data.in_iso in
- let in_prolog = !Data.in_prolog in
- match s with
- "identifier" when in_meta -> check_arity_context_linetype s; TIdentifier
- | "type" when in_meta -> check_arity_context_linetype s; TType
- | "parameter" when in_meta -> check_arity_context_linetype s; TParameter
- | "constant" when in_meta -> check_arity_context_linetype s; TConstant
- | "generated" when in_rule_name && not (!Flag.make_hrule = None) ->
- check_arity_context_linetype s; TGenerated
- | "expression" when in_meta || in_rule_name ->
- check_arity_context_linetype s; TExpression
- | "initialiser" when in_meta || in_rule_name ->
- check_arity_context_linetype s; TInitialiser
- | "initializer" when in_meta || in_rule_name ->
- check_arity_context_linetype s; TInitialiser
- | "idexpression" when in_meta ->
- check_arity_context_linetype s; TIdExpression
- | "statement" when in_meta -> check_arity_context_linetype s; TStatement
- | "function" when in_meta -> check_arity_context_linetype s; TFunction
- | "local" when in_meta -> check_arity_context_linetype s; TLocal
- | "list" when in_meta -> check_arity_context_linetype s; Tlist
- | "fresh" when in_meta -> check_arity_context_linetype s; TFresh
- | "typedef" when in_meta -> check_arity_context_linetype s; TTypedef
- | "declarer" when in_meta -> check_arity_context_linetype s; TDeclarer
- | "iterator" when in_meta -> check_arity_context_linetype s; TIterator
- | "name" when in_meta -> check_arity_context_linetype s; TName
- | "position" when in_meta -> check_arity_context_linetype s; TPosition
- | "any" when in_meta -> check_arity_context_linetype s; TPosAny
- | "pure" when in_meta && in_iso ->
- check_arity_context_linetype s; TPure
- | "context" when in_meta && in_iso ->
- check_arity_context_linetype s; TContext
- | "error" when in_meta -> check_arity_context_linetype s; TError
- | "words" when in_meta -> check_context_linetype s; TWords
-
- | "using" when in_rule_name || in_prolog -> check_context_linetype s; TUsing
- | "disable" when in_rule_name -> check_context_linetype s; TDisable
- | "extends" when in_rule_name -> check_context_linetype s; TExtends
- | "depends" when in_rule_name -> check_context_linetype s; TDepends
- | "on" when in_rule_name -> check_context_linetype s; TOn
- | "ever" when in_rule_name -> check_context_linetype s; TEver
- | "never" when in_rule_name -> check_context_linetype s; TNever
- | "exists" when in_rule_name -> check_context_linetype s; TExists
- | "forall" when in_rule_name -> check_context_linetype s; TForall
- | "reverse" when in_rule_name -> check_context_linetype s; TReverse
- | "script" when in_rule_name -> check_context_linetype s; TScript
-
- | "char" -> Tchar linetype
- | "short" -> Tshort linetype
- | "int" -> Tint linetype
- | "double" -> Tdouble linetype
- | "float" -> Tfloat linetype
- | "long" -> Tlong linetype
- | "void" -> Tvoid linetype
- | "struct" -> Tstruct linetype
- | "union" -> Tunion linetype
- | "enum" -> Tenum linetype
- | "unsigned" -> Tunsigned linetype
- | "signed" -> Tsigned linetype
-
- | "auto" -> Tauto linetype
- | "register" -> Tregister linetype
- | "extern" -> Textern linetype
- | "static" -> Tstatic linetype
- | "inline" -> Tinline linetype
- | "typedef" -> Ttypedef linetype
-
- | "const" -> Tconst linetype
- | "volatile" -> Tvolatile linetype
-
- | "if" -> TIf linetype
- | "else" -> TElse linetype
- | "while" -> TWhile linetype
- | "do" -> TDo linetype
- | "for" -> TFor linetype
- | "switch" -> TSwitch linetype
- | "case" -> TCase linetype
- | "default" -> TDefault linetype
- | "return" -> TReturn linetype
- | "break" -> TBreak linetype
- | "continue" -> TContinue linetype
- | "goto" -> TGoto linetype
-
- | "sizeof" -> TSizeof linetype
-
- | "Expression" -> TIsoExpression
- | "ArgExpression" -> TIsoArgExpression
- | "TestExpression" -> TIsoTestExpression
- | "Statement" -> TIsoStatement
- | "Declaration" -> TIsoDeclaration
- | "Type" -> TIsoType
- | "TopLevel" -> TIsoTopLevel
-
- | s -> check_var s linetype
-
-let mkassign op lexbuf =
- TAssign (Ast.OpAssign op, (get_current_line_type lexbuf))
-
-let init _ =
- line := 1;
- logical_line := 0;
- prev_plus := false;
- line_start := 0;
- current_line_started := false;
- col_zero := true;
- pm := UNKNOWN;
- Data.in_rule_name := false;
- Data.in_meta := false;
- Data.in_prolog := false;
- Data.inheritable_positions := [];
- Hashtbl.clear all_metavariables;
- Hashtbl.clear Data.all_metadecls;
- Hashtbl.clear metavariables;
- Hashtbl.clear type_names;
- Hashtbl.clear rule_names;
- let get_name (_,x) = x in
- Data.add_id_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaId(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_type_meta :=
- (fun name pure ->
- let fn clt = TMetaType(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_init_meta :=
- (fun name pure ->
- let fn clt = TMetaInit(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_param_meta :=
- (function name -> function pure ->
- let fn clt = TMetaParam(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_paramlist_meta :=
- (function name -> function lenname -> function pure ->
- let fn clt = TMetaParamList(name,lenname,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_const_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaConst(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_err_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaErr(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_exp_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaExp(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_idexp_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaIdExp(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_local_idexp_meta :=
- (fun tyopt name constraints pure ->
- let fn clt = TMetaLocalIdExp(name,constraints,pure,tyopt,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_explist_meta :=
- (function name -> function lenname -> function pure ->
- let fn clt = TMetaExpList(name,lenname,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_stm_meta :=
- (function name -> function pure ->
- let fn clt = TMetaStm(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_stmlist_meta :=
- (function name -> function pure ->
- let fn clt = TMetaStmList(name,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_func_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaFunc(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_local_func_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaLocalFunc(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_iterator_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaIterator(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_declarer_meta :=
- (fun name constraints pure ->
- let fn clt = TMetaDeclarer(name,constraints,pure,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_pos_meta :=
- (fun name constraints any ->
- let fn ((d,ln,_,_,_,_,_,_) as clt) =
- (if d = Data.PLUS
- then
- failwith
- (Printf.sprintf "%d: positions only allowed in minus code" ln));
- TMetaPos(name,constraints,any,clt) in
- Hashtbl.replace metavariables (get_name name) fn);
- Data.add_type_name :=
- (function name ->
- let fn clt = TTypeId(name,clt) in
- Hashtbl.replace type_names name fn);
- Data.add_declarer_name :=
- (function name ->
- let fn clt = TDeclarerId(name,clt) in
- Hashtbl.replace declarer_names name fn);
- Data.add_iterator_name :=
- (function name ->
- let fn clt = TIteratorId(name,clt) in
- Hashtbl.replace iterator_names name fn);
- Data.init_rule := (function _ -> Hashtbl.clear metavariables);
- Data.install_bindings :=
- (function parent ->
- List.iter (function (name,fn) -> Hashtbl.add metavariables name fn)
- (Hashtbl.find all_metavariables parent))
-
-let drop_spaces s =
- let len = String.length s in
- let rec loop n =
- if n = len
- then n
- else
- if List.mem (String.get s n) [' ';'\t']
- then loop (n+1)
- else n in
- let start = loop 0 in
- String.sub s start (len - start)
-}
-
-(* ---------------------------------------------------------------------- *)
-(* tokens *)
-
-let letter = ['A'-'Z' 'a'-'z' '_']
-let digit = ['0'-'9']
-
-let dec = ['0'-'9']
-let oct = ['0'-'7']
-let hex = ['0'-'9' 'a'-'f' 'A'-'F']
-
-let decimal = ('0' | (['1'-'9'] dec*))
-let octal = ['0'] oct+
-let hexa = ("0x" |"0X") hex+
-
-let pent = dec+
-let pfract = dec+
-let sign = ['-' '+']
-let exp = ['e''E'] sign? dec+
-let real = pent exp | ((pent? '.' pfract | pent '.' pfract? ) exp?)
-
-
-rule token = parse
- | [' ' '\t' ]+ { start_line false; token lexbuf }
- | ['\n' '\r' '\011' '\012'] { reset_line lexbuf; token lexbuf }
-
- | "//" [^ '\n']* { start_line false; token lexbuf }
-
- | "@@" { start_line true; TArobArob }
- | "@" { pass_zero();
- if !Data.in_rule_name or not !current_line_started
- then (start_line true; TArob)
- else (check_minus_context_linetype "@"; TPArob) }
-
- | "WHEN" | "when"
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TWhen (get_current_line_type lexbuf) }
-
- | "..."
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TEllipsis (get_current_line_type lexbuf) }
-(*
- | "ooo"
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TCircles (get_current_line_type lexbuf) }
-
- | "***"
- { start_line true; check_minus_context_linetype (tok lexbuf);
- TStars (get_current_line_type lexbuf) }
-*)
- | "<..." { start_line true; check_context_linetype (tok lexbuf);
- TOEllipsis (get_current_line_type lexbuf) }
- | "...>" { start_line true; check_context_linetype (tok lexbuf);
- TCEllipsis (get_current_line_type lexbuf) }
- | "<+..." { start_line true; check_context_linetype (tok lexbuf);
- TPOEllipsis (get_current_line_type lexbuf) }
- | "...+>" { start_line true; check_context_linetype (tok lexbuf);
- TPCEllipsis (get_current_line_type lexbuf) }
-(*
- | "<ooo" { start_line true; check_context_linetype (tok lexbuf);
- TOCircles (get_current_line_type lexbuf) }
- | "ooo>" { start_line true; check_context_linetype (tok lexbuf);
- TCCircles (get_current_line_type lexbuf) }
-
- | "<***" { start_line true; check_context_linetype (tok lexbuf);
- TOStars (get_current_line_type lexbuf) }
- | "***>" { start_line true; check_context_linetype (tok lexbuf);
- TCStars (get_current_line_type lexbuf) }
-*)
- | "-" { pass_zero();
- if !current_line_started
- then (start_line true; TMinus (get_current_line_type lexbuf))
- else (patch_or_match PATCH;
- add_current_line_type D.MINUS; token lexbuf) }
- | "+" { pass_zero();
- if !current_line_started
- then (start_line true; TPlus (get_current_line_type lexbuf))
- else if !Data.in_meta
- then TPlus0
- else (patch_or_match PATCH;
- add_current_line_type D.PLUS; token lexbuf) }
- | "?" { pass_zero();
- if !current_line_started
- then (start_line true; TWhy (get_current_line_type lexbuf))
- else if !Data.in_meta
- then TWhy0
- else (add_current_line_type D.OPT; token lexbuf) }
- | "!" { pass_zero();
- if !current_line_started
- then (start_line true; TBang (get_current_line_type lexbuf))
- else if !Data.in_meta
- then TBang0
- else (add_current_line_type D.UNIQUE; token lexbuf) }
- | "(" { if not !col_zero
- then (start_line true; TOPar (get_current_line_type lexbuf))
- else
- (start_line true; check_context_linetype (tok lexbuf);
- TOPar0 (get_current_line_type lexbuf))}
- | "\\(" { start_line true; TOPar0 (get_current_line_type lexbuf) }
- | "|" { if not (!col_zero)
- then (start_line true; TOr(get_current_line_type lexbuf))
- else (start_line true;
- check_context_linetype (tok lexbuf);
- TMid0 (get_current_line_type lexbuf))}
- | "\\|" { start_line true; TMid0 (get_current_line_type lexbuf) }
- | ")" { if not !col_zero
- then (start_line true; TCPar (get_current_line_type lexbuf))
- else
- (start_line true; check_context_linetype (tok lexbuf);
- TCPar0 (get_current_line_type lexbuf))}
- | "\\)" { start_line true; TCPar0 (get_current_line_type lexbuf) }
-
- | '[' { start_line true; TOCro (get_current_line_type lexbuf) }
- | ']' { start_line true; TCCro (get_current_line_type lexbuf) }
- | '{' { start_line true; TOBrace (get_current_line_type lexbuf) }
- | '}' { start_line true; TCBrace (get_current_line_type lexbuf) }
-
- | "->" { start_line true; TPtrOp (get_current_line_type lexbuf) }
- | '.' { start_line true; TDot (get_current_line_type lexbuf) }
- | ',' { start_line true; TComma (get_current_line_type lexbuf) }
- | ";" { start_line true;
- if !Data.in_meta
- then TMPtVirg (* works better with tokens_all *)
- else TPtVirg (get_current_line_type lexbuf) }
-
-
- | '*' { pass_zero();
- if !current_line_started
- then
- (start_line true; TMul (get_current_line_type lexbuf))
- else
- (patch_or_match MATCH;
- add_current_line_type D.MINUS; token lexbuf) }
- | '/' { start_line true;
- TDmOp (Ast.Div,get_current_line_type lexbuf) }
- | '%' { start_line true;
- TDmOp (Ast.Mod,get_current_line_type lexbuf) }
- | '~' { start_line true; TTilde (get_current_line_type lexbuf) }
-
- | "++" { start_line true; TInc (get_current_line_type lexbuf) }
- | "--" { start_line true; TDec (get_current_line_type lexbuf) }
-
- | "=" { start_line true; TEq (get_current_line_type lexbuf) }
-
- | "-=" { start_line true; mkassign Ast.Minus lexbuf }
- | "+=" { start_line true; mkassign Ast.Plus lexbuf }
-
- | "*=" { start_line true; mkassign Ast.Mul lexbuf }
- | "/=" { start_line true; mkassign Ast.Div lexbuf }
- | "%=" { start_line true; mkassign Ast.Mod lexbuf }
-
- | "&=" { start_line true; mkassign Ast.And lexbuf }
- | "|=" { start_line true; mkassign Ast.Or lexbuf }
- | "^=" { start_line true; mkassign Ast.Xor lexbuf }
-
- | "<<=" { start_line true; mkassign Ast.DecLeft lexbuf }
- | ">>=" { start_line true; mkassign Ast.DecRight lexbuf }
-
- | ":" { start_line true; TDotDot (get_current_line_type lexbuf) }
-
- | "==" { start_line true; TEqEq (get_current_line_type lexbuf) }
- | "!=" { start_line true; TNotEq (get_current_line_type lexbuf) }
- | ">=" { start_line true;
- TLogOp(Ast.SupEq,get_current_line_type lexbuf) }
- | "<=" { start_line true;
- TLogOp(Ast.InfEq,get_current_line_type lexbuf) }
- | "<" { start_line true;
- TLogOp(Ast.Inf,get_current_line_type lexbuf) }
- | ">" { start_line true;
- TLogOp(Ast.Sup,get_current_line_type lexbuf) }
-
- | "&&" { start_line true; TAndLog (get_current_line_type lexbuf) }
- | "||" { start_line true; TOrLog (get_current_line_type lexbuf) }
-
- | ">>" { start_line true;
- TShOp(Ast.DecRight,get_current_line_type lexbuf) }
- | "<<" { start_line true;
- TShOp(Ast.DecLeft,get_current_line_type lexbuf) }
-
- | "&" { start_line true; TAnd (get_current_line_type lexbuf) }
- | "^" { start_line true; TXor(get_current_line_type lexbuf) }
-
- | ( ("#" [' ' '\t']* "define" [' ' '\t']+))
- ( (letter (letter |digit)*) as ident)
- { start_line true;
- let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
- get_current_line_type lexbuf in
- let off = String.length "#define " in
- (* -1 in the code below because the ident is not at the line start *)
- TDefine
- (lt,
- check_var ident
- (arity,line,lline,offset+off,(-1),[],[],Ast0.NoMetaPos)) }
- | ( ("#" [' ' '\t']* "define" [' ' '\t']+))
- ( (letter (letter | digit)*) as ident)
- '('
- { start_line true;
- let (arity,line,lline,offset,col,strbef,straft,pos) as lt =
- get_current_line_type lexbuf in
- let off = String.length "#define " in
- TDefineParam
- (lt,
- check_var ident
- (* why pos here but not above? *)
- (arity,line,lline,offset+off,(-1),strbef,straft,pos),
- offset + off + (String.length ident)) }
- | "#" [' ' '\t']* "include" [' ' '\t']* '"' [^ '"']+ '"'
- { TIncludeL
- (let str = tok lexbuf in
- let start = String.index str '"' in
- let finish = String.rindex str '"' in
- start_line true;
- (process_include start finish str,get_current_line_type lexbuf)) }
- | "#" [' ' '\t']* "include" [' ' '\t']* '<' [^ '>']+ '>'
- { TIncludeNL
- (let str = tok lexbuf in
- let start = String.index str '<' in
- let finish = String.rindex str '>' in
- start_line true;
- (process_include start finish str,get_current_line_type lexbuf)) }
- | "#" [' ' '\t']* "if" [^'\n']*
- | "#" [' ' '\t']* "ifdef" [^'\n']*
- | "#" [' ' '\t']* "ifndef" [^'\n']*
- | "#" [' ' '\t']* "else" [^'\n']*
- | "#" [' ' '\t']* "elif" [^'\n']*
- | "#" [' ' '\t']* "endif" [^'\n']*
- | "#" [' ' '\t']* "error" [^'\n']*
- { start_line true; check_plus_linetype (tok lexbuf);
- TPragma (tok lexbuf) }
- | "---" [^'\n']*
- { (if !current_line_started
- then lexerr "--- must be at the beginning of the line" "");
- start_line true;
- TMinusFile
- (let str = tok lexbuf in
- (drop_spaces(String.sub str 3 (String.length str - 3)),
- (get_current_line_type lexbuf))) }
- | "+++" [^'\n']*
- { (if !current_line_started
- then lexerr "+++ must be at the beginning of the line" "");
- start_line true;
- TPlusFile
- (let str = tok lexbuf in
- (drop_spaces(String.sub str 3 (String.length str - 3)),
- (get_current_line_type lexbuf))) }
-
- | letter (letter | digit)*
- { start_line true; id_tokens lexbuf }
-
- | "'" { start_line true;
- TChar(char lexbuf,get_current_line_type lexbuf) }
- | '"' { start_line true;
- TString(string lexbuf,(get_current_line_type lexbuf)) }
- | (real as x) { start_line true;
- TFloat(x,(get_current_line_type lexbuf)) }
- | ((( decimal | hexa | octal)
- ( ['u' 'U']
- | ['l' 'L']
- | (['l' 'L'] ['u' 'U'])
- | (['u' 'U'] ['l' 'L'])
- | (['u' 'U'] ['l' 'L'] ['l' 'L'])
- | (['l' 'L'] ['l' 'L'])
- )?
- ) as x) { start_line true; TInt(x,(get_current_line_type lexbuf)) }
-
- | "<=>" { TIso }
- | "=>" { TRightIso }
-
- | eof { EOF }
-
- | _ { lexerr "unrecognised symbol, in token rule: " (tok lexbuf) }
-
-
-and char = parse
- | (_ as x) "'" { String.make 1 x }
- | (("\\" (oct | oct oct | oct oct oct)) as x "'") { x }
- | (("\\x" (hex | hex hex)) as x "'") { x }
- | (("\\" (_ as v)) as x "'")
- { (match v with
- | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> ()
- | 'r' -> () | 'f' -> () | 'a' -> ()
- | '\\' -> () | '?' -> () | '\'' -> () | '"' -> ()
- | 'e' -> ()
- | _ -> lexerr "unrecognised symbol: " (tok lexbuf)
- );
- x
- }
- | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
-
-and string = parse
- | '"' { "" }
- | (_ as x) { Common.string_of_char x ^ string lexbuf }
- | ("\\" (oct | oct oct | oct oct oct)) as x { x ^ string lexbuf }
- | ("\\x" (hex | hex hex)) as x { x ^ string lexbuf }
- | ("\\" (_ as v)) as x
- {
- (match v with
- | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> () | 'r' -> ()
- | 'f' -> () | 'a' -> ()
- | '\\' -> () | '?' -> () | '\'' -> () | '"' -> ()
- | 'e' -> ()
- | '\n' -> ()
- | _ -> lexerr "unrecognised symbol:" (tok lexbuf)
- );
- x ^ string lexbuf
- }
- | _ { lexerr "unrecognised symbol: " (tok lexbuf) }
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* exports everything, used only by parser_cocci_menhir.mly *)
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* types for metavariable tokens *)
-type info = Ast.meta_name * Ast0.pure * Data.clt
-type idinfo = Ast.meta_name * Data.iconstraints * Ast0.pure * Data.clt
-type expinfo = Ast.meta_name * Data.econstraints * Ast0.pure * Data.clt
-type tyinfo = Ast.meta_name * Ast0.typeC list * Ast0.pure * Data.clt
-type list_info = Ast.meta_name * Ast.meta_name option * Ast0.pure * Data.clt
-type typed_info =
- Ast.meta_name * Data.econstraints * Ast0.pure *
- Type_cocci.typeC list option * Data.clt
-type pos_info = Ast.meta_name * Data.pconstraints * Ast.meta_collect * Data.clt
-
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-let make_info line logical_line offset col strbef straft =
- { Ast0.line_start = line; Ast0.line_end = line;
- Ast0.logical_start = logical_line; Ast0.logical_end = logical_line;
- Ast0.attachable_start = true; Ast0.attachable_end = true;
- Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.column = col; Ast0.offset = offset;
- Ast0.strings_before = strbef; Ast0.strings_after = straft; }
-
-let clt2info (_,line,logical_line,offset,col,strbef,straft,pos) =
- make_info line logical_line offset col strbef straft
-
-let drop_bef (arity,line,lline,offset,col,strbef,straft,pos) =
- (arity,line,lline,offset,col,[],straft,pos)
-
-let drop_aft (arity,line,lline,offset,col,strbef,straft,pos) =
- (arity,line,lline,offset,col,strbef,[],pos)
-
-let clt2mcode str = function
- (Data.MINUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.NONE,make_info line lline offset col strbef straft,
- Ast0.MINUS(ref([],Ast0.default_token_info)),ref pos)
- | (Data.OPTMINUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.OPT,make_info line lline offset col strbef straft,
- Ast0.MINUS(ref([],Ast0.default_token_info)),ref pos)
- | (Data.UNIQUEMINUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.UNIQUE,make_info line lline offset col strbef straft,
- Ast0.MINUS(ref([],Ast0.default_token_info)),ref pos)
- | (Data.PLUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.NONE,make_info line lline offset col strbef straft,Ast0.PLUS,
- ref pos)
- | (Data.CONTEXT,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.NONE,make_info line lline offset col strbef straft,
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info)),
- ref pos)
- | (Data.OPT,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.OPT,make_info line lline offset col strbef straft,
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info)),
- ref pos)
- | (Data.UNIQUE,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.UNIQUE,make_info line lline offset col strbef straft,
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info)),
- ref pos)
-
-let id2name (name, clt) = name
-let id2clt (name, clt) = clt
-let id2mcode (name, clt) = clt2mcode name clt
-
-let mkdots str (dot,whencode) =
- match str with
- "..." -> Ast0.wrap(Ast0.Dots(clt2mcode str dot, whencode))
- | "ooo" -> Ast0.wrap(Ast0.Circles(clt2mcode str dot, whencode))
- | "***" -> Ast0.wrap(Ast0.Stars(clt2mcode str dot, whencode))
- | _ -> failwith "cannot happen"
-
-let mkedots str (dot,whencode) =
- match str with
- "..." -> Ast0.wrap(Ast0.Edots(clt2mcode str dot, whencode))
- | "ooo" -> Ast0.wrap(Ast0.Ecircles(clt2mcode str dot, whencode))
- | "***" -> Ast0.wrap(Ast0.Estars(clt2mcode str dot, whencode))
- | _ -> failwith "cannot happen"
-
-let mkdpdots str dot =
- match str with
- "..." -> Ast0.wrap(Ast0.DPdots(clt2mcode str dot))
- | "ooo" -> Ast0.wrap(Ast0.DPcircles(clt2mcode str dot))
- | _ -> failwith "cannot happen"
-
-let mkidots str (dot,whencode) =
- match str with
- "..." -> Ast0.wrap(Ast0.Idots(clt2mcode str dot, whencode))
- | _ -> failwith "cannot happen"
-
-let mkddots str (dot,whencode) =
- match (str,whencode) with
- ("...",None) -> Ast0.wrap(Ast0.Ddots(clt2mcode str dot, None))
- | ("...",Some [w]) -> Ast0.wrap(Ast0.Ddots(clt2mcode str dot, Some w))
- | _ -> failwith "cannot happen"
-
-let mkpdots str dot =
- match str with
- "..." -> Ast0.wrap(Ast0.Pdots(clt2mcode str dot))
- | "ooo" -> Ast0.wrap(Ast0.Pcircles(clt2mcode str dot))
- | _ -> failwith "cannot happen"
-
-let arith_op ast_op left op right =
- Ast0.wrap
- (Ast0.Binary(left, clt2mcode (Ast.Arith ast_op) op, right))
-
-let logic_op ast_op left op right =
- Ast0.wrap
- (Ast0.Binary(left, clt2mcode (Ast.Logical ast_op) op, right))
-
-let make_cv cv ty =
- match cv with None -> ty | Some x -> Ast0.wrap (Ast0.ConstVol(x,ty))
-
-let top_dots l =
- let circle x =
- match Ast0.unwrap x with Ast0.Circles(_) -> true | _ -> false in
- let star x =
- match Ast0.unwrap x with Ast0.Stars(_) -> true | _ -> false in
- if List.exists circle l
- then Ast0.wrap(Ast0.CIRCLES(l))
- else
- if List.exists star l
- then Ast0.wrap(Ast0.STARS(l))
- else Ast0.wrap(Ast0.DOTS(l))
-
-(* here the offset is that of the first in the sequence of *s, not that of
-each * individually *)
-let pointerify ty m =
- List.fold_left
- (function inner ->
- function cur ->
- Ast0.wrap(Ast0.Pointer(inner,clt2mcode "*" cur)))
- ty m
-
-let ty_pointerify ty m =
- List.fold_left
- (function inner -> function cur -> Type_cocci.Pointer(inner))
- ty m
-
-(* Left is <=>, Right is =>. Collect <=>s. *)
-(* The parser should have done this, with precedences. But whatever... *)
-let iso_adjust fn first rest =
- let rec loop = function
- [] -> [[]]
- | (Common.Left x)::rest ->
- (match loop rest with
- front::after -> (fn x::front)::after
- | _ -> failwith "not possible")
- | (Common.Right x)::rest ->
- (match loop rest with
- front::after -> []::(fn x::front)::after
- | _ -> failwith "not possible") in
- match loop rest with
- front::after -> (fn first::front)::after
- | _ -> failwith "not possible"
-
-let check_meta tok =
- let lookup rule name =
- try
- let info = Hashtbl.find Data.all_metadecls rule in
- List.find (function mv -> Ast.get_meta_name mv = (rule,name)) info
- with
- Not_found ->
- raise
- (Semantic_cocci.Semantic
- ("bad rule "^rule^" or bad variable "^name)) in
- match tok with
- Ast.MetaIdDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaIdDecl(_,_) | Ast.MetaFreshIdDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaFreshIdDecl(Ast.NONE,(rule,name)) ->
- raise
- (Semantic_cocci.Semantic
- "can't inherit the freshness of an identifier")
- | Ast.MetaListlenDecl((rule,name)) ->
- (match lookup rule name with
- Ast.MetaListlenDecl(_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaTypeDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaTypeDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaParamDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaParamDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaParamListDecl(Ast.NONE,(rule,name),len_name) ->
- (match lookup rule name with
- Ast.MetaParamListDecl(_,_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaErrDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaErrDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaExpDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaExpDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaIdExpDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaIdExpDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaLocalIdExpDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaLocalIdExpDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaExpListDecl(Ast.NONE,(rule,name),len_name) ->
- (match lookup rule name with
- Ast.MetaExpListDecl(_,_,_) -> ()
- | Ast.MetaParamListDecl(_,_,_) when not (!Flag.make_hrule = None) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaStmDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaStmDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaStmListDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaStmListDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaFuncDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaFuncDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaLocalFuncDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaLocalFuncDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaConstDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaConstDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaPosDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaPosDecl(_,_) ->
- if not (List.mem rule !Data.inheritable_positions)
- then
- raise
- (Semantic_cocci.Semantic
- ("position cannot be inherited over modifications: "^name))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | _ ->
- raise
- (Semantic_cocci.Semantic ("arity not allowed on imported declaration"))
-
-let create_metadec ar ispure kindfn ids current_rule =
- List.concat
- (List.map
- (function (rule,nm) ->
- let (rule,checker) =
- match rule with
- None -> ((current_rule,nm),function x -> [Common.Left x])
- | Some rule ->
- ((rule,nm),
- function x -> check_meta x; [Common.Right x]) in
- kindfn ar rule ispure checker)
- ids)
-
-let create_metadec_ne ar ispure kindfn ids current_rule =
- List.concat
- (List.map
- (function ((rule,nm),constraints) ->
- let (rule,checker) =
- match rule with
- None -> ((current_rule,nm),function x -> [Common.Left x])
- | Some rule ->
- ((rule,nm),
- function x -> check_meta x; [Common.Right x]) in
- kindfn ar rule ispure checker constraints)
- ids)
-
-let create_metadec_ty ar ispure kindfn ids current_rule =
- List.concat
- (List.map
- (function ((rule,nm),constraints) ->
- let (rule,checker) =
- match rule with
- None -> ((current_rule,nm),function x -> [Common.Left x])
- | Some rule ->
- ((rule,nm),
- function x -> check_meta x; [Common.Right x]) in
- kindfn ar rule ispure checker constraints)
- ids)
-
-let create_len_metadec ar ispure kindfn lenid ids current_rule =
- let lendec =
- create_metadec Ast.NONE Ast0.Impure
- (fun _ name _ check_meta -> check_meta(Ast.MetaListlenDecl(name)))
- [lenid] current_rule in
- let lenname =
- match lendec with
- [Common.Left (Ast.MetaListlenDecl(x))] -> x
- | [Common.Right (Ast.MetaListlenDecl(x))] -> x
- | _ -> failwith "unexpected length declaration" in
- lendec@(create_metadec ar ispure (kindfn lenname) ids current_rule)
-
-(* ---------------------------------------------------------------------- *)
-
-let str2inc s =
- let elements = Str.split (Str.regexp "/") s in
- List.map (function "..." -> Ast.IncDots | s -> Ast.IncPath s) elements
-
-(* ---------------------------------------------------------------------- *)
-(* statements *)
-
-let meta_stm name =
- let (nm,pure,clt) = name in
- Ast0.wrap(Ast0.MetaStmt(clt2mcode nm clt,pure))
-
-let exp_stm exp pv =
- Ast0.wrap(Ast0.ExprStatement (exp, clt2mcode ";" pv))
-
-let ifthen iff lp tst rp thn =
- Ast0.wrap(Ast0.IfThen(clt2mcode "if" iff,
- clt2mcode "(" lp,tst,clt2mcode ")" rp,thn,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let ifthenelse iff lp tst rp thn e els =
- Ast0.wrap(Ast0.IfThenElse(clt2mcode "if" iff,
- clt2mcode "(" lp,tst,clt2mcode ")" rp,thn,
- clt2mcode "else" e,els,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let forloop fr lp e1 sc1 e2 sc2 e3 rp s =
- Ast0.wrap(Ast0.For(clt2mcode "for" fr,clt2mcode "(" lp,e1,
- clt2mcode ";" sc1,e2,
- clt2mcode ";" sc2,e3,clt2mcode ")" rp,s,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let whileloop w lp e rp s =
- Ast0.wrap(Ast0.While(clt2mcode "while" w,clt2mcode "(" lp,
- e,clt2mcode ")" rp,s,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let doloop d s w lp e rp pv =
- Ast0.wrap(Ast0.Do(clt2mcode "do" d,s,clt2mcode "while" w,
- clt2mcode "(" lp,e,clt2mcode ")" rp,
- clt2mcode ";" pv))
-
-let iterator i lp e rp s =
- Ast0.wrap(Ast0.Iterator(i,clt2mcode "(" lp,e,clt2mcode ")" rp,s,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let switch s lp e rp lb c rb =
- Ast0.wrap(Ast0.Switch(clt2mcode "switch" s,clt2mcode "(" lp,e,
- clt2mcode ")" rp,clt2mcode "{" lb,
- Ast0.wrap(Ast0.DOTS(c)),clt2mcode "}" rb))
-
-let ret_exp r e pv =
- Ast0.wrap(Ast0.ReturnExpr(clt2mcode "return" r,e,clt2mcode ";" pv))
-
-let ret r pv =
- Ast0.wrap(Ast0.Return(clt2mcode "return" r,clt2mcode ";" pv))
-
-let break b pv =
- Ast0.wrap(Ast0.Break(clt2mcode "break" b,clt2mcode ";" pv))
-
-let cont c pv =
- Ast0.wrap(Ast0.Continue(clt2mcode "continue" c,clt2mcode ";" pv))
-
-let label i dd =
- Ast0.wrap(Ast0.Label(i,clt2mcode ":" dd))
-
-let goto g i pv =
- Ast0.wrap(Ast0.Goto(clt2mcode "goto" g,i,clt2mcode ";" pv))
-
-let seq lb s rb =
- Ast0.wrap(Ast0.Seq(clt2mcode "{" lb,s,clt2mcode "}" rb))
-
-(* ---------------------------------------------------------------------- *)
-
-let make_iso_rule_name_result n =
- (try let _ = Hashtbl.find Data.all_metadecls n in
- raise (Semantic_cocci.Semantic ("repeated rule name"))
- with Not_found -> ());
- Ast.CocciRulename (Some n,Ast.NoDep,[],[],Ast.Undetermined,false (*discarded*))
-
-let make_cocci_rule_name_result nm d i a e ee =
- match nm with
- Some nm ->
- let n = id2name nm in
- (try let _ = Hashtbl.find Data.all_metadecls n in
- raise (Semantic_cocci.Semantic ("repeated rule name"))
- with Not_found -> ());
- Ast.CocciRulename (Some n,d,i,a,e,ee)
- | None -> Ast.CocciRulename (None,d,i,a,e,ee)
-
-let make_generated_rule_name_result nm d i a e ee =
- match nm with
- Some nm ->
- let n = id2name nm in
- (try let _ = Hashtbl.find Data.all_metadecls n in
- raise (Semantic_cocci.Semantic ("repeated rule name"))
- with Not_found -> ());
- Ast.GeneratedRulename (Some n,d,i,a,e,ee)
- | None -> Ast.GeneratedRulename (None,d,i,a,e,ee)
-
-let make_script_rule_name_result lang deps =
- let l = id2name lang in
- Ast.ScriptRulename (l,deps)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* exports everything, used only by parser_cocci_menhir.mly *)
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-
-(* types for metavariable tokens *)
-type info = Ast.meta_name * Ast0.pure * Data.clt
-type idinfo = Ast.meta_name * Data.iconstraints * Ast0.pure * Data.clt
-type expinfo = Ast.meta_name * Data.econstraints * Ast0.pure * Data.clt
-type tyinfo = Ast.meta_name * Ast0.typeC list * Ast0.pure * Data.clt
-type list_info = Ast.meta_name * Ast.meta_name option * Ast0.pure * Data.clt
-type typed_info =
- Ast.meta_name * Data.econstraints * Ast0.pure *
- Type_cocci.typeC list option * Data.clt
-type pos_info = Ast.meta_name * Data.pconstraints * Ast.meta_collect * Data.clt
-
-
-let get_option fn = function
- None -> None
- | Some x -> Some (fn x)
-
-let make_info line logical_line offset col strbef straft =
- { Ast0.line_start = line; Ast0.line_end = line;
- Ast0.logical_start = logical_line; Ast0.logical_end = logical_line;
- Ast0.attachable_start = true; Ast0.attachable_end = true;
- Ast0.mcode_start = []; Ast0.mcode_end = [];
- Ast0.column = col; Ast0.offset = offset;
- Ast0.strings_before = strbef; Ast0.strings_after = straft; }
-
-let clt2info (_,line,logical_line,offset,col,strbef,straft,pos) =
- make_info line logical_line offset col strbef straft
-
-let drop_bef (arity,line,lline,offset,col,strbef,straft,pos) =
- (arity,line,lline,offset,col,[],straft,pos)
-
-let drop_aft (arity,line,lline,offset,col,strbef,straft,pos) =
- (arity,line,lline,offset,col,strbef,[],pos)
-
-let clt2mcode str = function
- (Data.MINUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.NONE,make_info line lline offset col strbef straft,
- Ast0.MINUS(ref([],Ast0.default_token_info)),ref pos)
- | (Data.OPTMINUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.OPT,make_info line lline offset col strbef straft,
- Ast0.MINUS(ref([],Ast0.default_token_info)),ref pos)
- | (Data.UNIQUEMINUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.UNIQUE,make_info line lline offset col strbef straft,
- Ast0.MINUS(ref([],Ast0.default_token_info)),ref pos)
- | (Data.PLUS,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.NONE,make_info line lline offset col strbef straft,Ast0.PLUS,
- ref pos)
- | (Data.CONTEXT,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.NONE,make_info line lline offset col strbef straft,
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info)),
- ref pos)
- | (Data.OPT,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.OPT,make_info line lline offset col strbef straft,
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info)),
- ref pos)
- | (Data.UNIQUE,line,lline,offset,col,strbef,straft,pos) ->
- (str,Ast0.UNIQUE,make_info line lline offset col strbef straft,
- Ast0.CONTEXT(ref(Ast.NOTHING,
- Ast0.default_token_info,Ast0.default_token_info)),
- ref pos)
-
-let id2name (name, clt) = name
-let id2clt (name, clt) = clt
-let id2mcode (name, clt) = clt2mcode name clt
-
-let mkdots str (dot,whencode) =
- match str with
- "..." -> Ast0.wrap(Ast0.Dots(clt2mcode str dot, whencode))
- | "ooo" -> Ast0.wrap(Ast0.Circles(clt2mcode str dot, whencode))
- | "***" -> Ast0.wrap(Ast0.Stars(clt2mcode str dot, whencode))
- | _ -> failwith "cannot happen"
-
-let mkedots str (dot,whencode) =
- match str with
- "..." -> Ast0.wrap(Ast0.Edots(clt2mcode str dot, whencode))
- | "ooo" -> Ast0.wrap(Ast0.Ecircles(clt2mcode str dot, whencode))
- | "***" -> Ast0.wrap(Ast0.Estars(clt2mcode str dot, whencode))
- | _ -> failwith "cannot happen"
-
-let mkdpdots str dot =
- match str with
- "..." -> Ast0.wrap(Ast0.DPdots(clt2mcode str dot))
- | "ooo" -> Ast0.wrap(Ast0.DPcircles(clt2mcode str dot))
- | _ -> failwith "cannot happen"
-
-let mkidots str (dot,whencode) =
- match str with
- "..." -> Ast0.wrap(Ast0.Idots(clt2mcode str dot, whencode))
- | _ -> failwith "cannot happen"
-
-let mkddots str (dot,whencode) =
- match (str,whencode) with
- ("...",None) -> Ast0.wrap(Ast0.Ddots(clt2mcode str dot, None))
- | ("...",Some [w]) -> Ast0.wrap(Ast0.Ddots(clt2mcode str dot, Some w))
- | _ -> failwith "cannot happen"
-
-let mkpdots str dot =
- match str with
- "..." -> Ast0.wrap(Ast0.Pdots(clt2mcode str dot))
- | "ooo" -> Ast0.wrap(Ast0.Pcircles(clt2mcode str dot))
- | _ -> failwith "cannot happen"
-
-let arith_op ast_op left op right =
- Ast0.wrap
- (Ast0.Binary(left, clt2mcode (Ast.Arith ast_op) op, right))
-
-let logic_op ast_op left op right =
- Ast0.wrap
- (Ast0.Binary(left, clt2mcode (Ast.Logical ast_op) op, right))
-
-let make_cv cv ty =
- match cv with None -> ty | Some x -> Ast0.wrap (Ast0.ConstVol(x,ty))
-
-let top_dots l =
- let circle x =
- match Ast0.unwrap x with Ast0.Circles(_) -> true | _ -> false in
- let star x =
- match Ast0.unwrap x with Ast0.Stars(_) -> true | _ -> false in
- if List.exists circle l
- then Ast0.wrap(Ast0.CIRCLES(l))
- else
- if List.exists star l
- then Ast0.wrap(Ast0.STARS(l))
- else Ast0.wrap(Ast0.DOTS(l))
-
-(* here the offset is that of the first in the sequence of *s, not that of
-each * individually *)
-let pointerify ty m =
- List.fold_left
- (function inner ->
- function cur ->
- Ast0.wrap(Ast0.Pointer(inner,clt2mcode "*" cur)))
- ty m
-
-let ty_pointerify ty m =
- List.fold_left
- (function inner -> function cur -> Type_cocci.Pointer(inner))
- ty m
-
-(* Left is <=>, Right is =>. Collect <=>s. *)
-(* The parser should have done this, with precedences. But whatever... *)
-let iso_adjust fn first rest =
- let rec loop = function
- [] -> [[]]
- | (Common.Left x)::rest ->
- (match loop rest with
- front::after -> (fn x::front)::after
- | _ -> failwith "not possible")
- | (Common.Right x)::rest ->
- (match loop rest with
- front::after -> []::(fn x::front)::after
- | _ -> failwith "not possible") in
- match loop rest with
- front::after -> (fn first::front)::after
- | _ -> failwith "not possible"
-
-let check_meta tok =
- let lookup rule name =
- try
- let info = Hashtbl.find Data.all_metadecls rule in
- List.find (function mv -> Ast.get_meta_name mv = (rule,name)) info
- with
- Not_found ->
- raise
- (Semantic_cocci.Semantic
- ("bad rule "^rule^" or bad variable "^name)) in
- match tok with
- Ast.MetaIdDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaIdDecl(_,_) | Ast.MetaFreshIdDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaFreshIdDecl(Ast.NONE,(rule,name)) ->
- raise
- (Semantic_cocci.Semantic
- "can't inherit the freshness of an identifier")
- | Ast.MetaListlenDecl((rule,name)) ->
- (match lookup rule name with
- Ast.MetaListlenDecl(_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaTypeDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaTypeDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaInitDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaInitDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaParamDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaParamDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaParamListDecl(Ast.NONE,(rule,name),len_name) ->
- (match lookup rule name with
- Ast.MetaParamListDecl(_,_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaErrDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaErrDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaExpDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaExpDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaIdExpDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaIdExpDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaLocalIdExpDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaLocalIdExpDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaExpListDecl(Ast.NONE,(rule,name),len_name) ->
- (match lookup rule name with
- Ast.MetaExpListDecl(_,_,_) -> ()
- | Ast.MetaParamListDecl(_,_,_) when not (!Flag.make_hrule = None) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaStmDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaStmDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaStmListDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaStmListDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaFuncDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaFuncDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaLocalFuncDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaLocalFuncDecl(_,_) -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaConstDecl(Ast.NONE,(rule,name),ty) ->
- (match lookup rule name with
- Ast.MetaConstDecl(_,_,ty1) when ty = ty1 -> ()
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | Ast.MetaPosDecl(Ast.NONE,(rule,name)) ->
- (match lookup rule name with
- Ast.MetaPosDecl(_,_) ->
- if not (List.mem rule !Data.inheritable_positions)
- then
- raise
- (Semantic_cocci.Semantic
- ("position cannot be inherited over modifications: "^name))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- ("incompatible inheritance declaration "^name)))
- | _ ->
- raise
- (Semantic_cocci.Semantic ("arity not allowed on imported declaration"))
-
-let create_metadec ar ispure kindfn ids current_rule =
- List.concat
- (List.map
- (function (rule,nm) ->
- let (rule,checker) =
- match rule with
- None -> ((current_rule,nm),function x -> [Common.Left x])
- | Some rule ->
- ((rule,nm),
- function x -> check_meta x; [Common.Right x]) in
- kindfn ar rule ispure checker)
- ids)
-
-let create_metadec_ne ar ispure kindfn ids current_rule =
- List.concat
- (List.map
- (function ((rule,nm),constraints) ->
- let (rule,checker) =
- match rule with
- None -> ((current_rule,nm),function x -> [Common.Left x])
- | Some rule ->
- ((rule,nm),
- function x -> check_meta x; [Common.Right x]) in
- kindfn ar rule ispure checker constraints)
- ids)
-
-let create_metadec_ty ar ispure kindfn ids current_rule =
- List.concat
- (List.map
- (function ((rule,nm),constraints) ->
- let (rule,checker) =
- match rule with
- None -> ((current_rule,nm),function x -> [Common.Left x])
- | Some rule ->
- ((rule,nm),
- function x -> check_meta x; [Common.Right x]) in
- kindfn ar rule ispure checker constraints)
- ids)
-
-let create_len_metadec ar ispure kindfn lenid ids current_rule =
- let lendec =
- create_metadec Ast.NONE Ast0.Impure
- (fun _ name _ check_meta -> check_meta(Ast.MetaListlenDecl(name)))
- [lenid] current_rule in
- let lenname =
- match lendec with
- [Common.Left (Ast.MetaListlenDecl(x))] -> x
- | [Common.Right (Ast.MetaListlenDecl(x))] -> x
- | _ -> failwith "unexpected length declaration" in
- lendec@(create_metadec ar ispure (kindfn lenname) ids current_rule)
-
-(* ---------------------------------------------------------------------- *)
-
-let str2inc s =
- let elements = Str.split (Str.regexp "/") s in
- List.map (function "..." -> Ast.IncDots | s -> Ast.IncPath s) elements
-
-(* ---------------------------------------------------------------------- *)
-(* statements *)
-
-let meta_stm name =
- let (nm,pure,clt) = name in
- Ast0.wrap(Ast0.MetaStmt(clt2mcode nm clt,pure))
-
-let exp_stm exp pv =
- Ast0.wrap(Ast0.ExprStatement (exp, clt2mcode ";" pv))
-
-let ifthen iff lp tst rp thn =
- Ast0.wrap(Ast0.IfThen(clt2mcode "if" iff,
- clt2mcode "(" lp,tst,clt2mcode ")" rp,thn,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let ifthenelse iff lp tst rp thn e els =
- Ast0.wrap(Ast0.IfThenElse(clt2mcode "if" iff,
- clt2mcode "(" lp,tst,clt2mcode ")" rp,thn,
- clt2mcode "else" e,els,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let forloop fr lp e1 sc1 e2 sc2 e3 rp s =
- Ast0.wrap(Ast0.For(clt2mcode "for" fr,clt2mcode "(" lp,e1,
- clt2mcode ";" sc1,e2,
- clt2mcode ";" sc2,e3,clt2mcode ")" rp,s,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let whileloop w lp e rp s =
- Ast0.wrap(Ast0.While(clt2mcode "while" w,clt2mcode "(" lp,
- e,clt2mcode ")" rp,s,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let doloop d s w lp e rp pv =
- Ast0.wrap(Ast0.Do(clt2mcode "do" d,s,clt2mcode "while" w,
- clt2mcode "(" lp,e,clt2mcode ")" rp,
- clt2mcode ";" pv))
-
-let iterator i lp e rp s =
- Ast0.wrap(Ast0.Iterator(i,clt2mcode "(" lp,e,clt2mcode ")" rp,s,
- (Ast0.default_info(),Ast0.context_befaft())))
-
-let switch s lp e rp lb c rb =
- Ast0.wrap(Ast0.Switch(clt2mcode "switch" s,clt2mcode "(" lp,e,
- clt2mcode ")" rp,clt2mcode "{" lb,
- Ast0.wrap(Ast0.DOTS(c)),clt2mcode "}" rb))
-
-let ret_exp r e pv =
- Ast0.wrap(Ast0.ReturnExpr(clt2mcode "return" r,e,clt2mcode ";" pv))
-
-let ret r pv =
- Ast0.wrap(Ast0.Return(clt2mcode "return" r,clt2mcode ";" pv))
-
-let break b pv =
- Ast0.wrap(Ast0.Break(clt2mcode "break" b,clt2mcode ";" pv))
-
-let cont c pv =
- Ast0.wrap(Ast0.Continue(clt2mcode "continue" c,clt2mcode ";" pv))
-
-let label i dd =
- Ast0.wrap(Ast0.Label(i,clt2mcode ":" dd))
-
-let goto g i pv =
- Ast0.wrap(Ast0.Goto(clt2mcode "goto" g,i,clt2mcode ";" pv))
-
-let seq lb s rb =
- Ast0.wrap(Ast0.Seq(clt2mcode "{" lb,s,clt2mcode "}" rb))
-
-(* ---------------------------------------------------------------------- *)
-
-let make_iso_rule_name_result n =
- (try let _ = Hashtbl.find Data.all_metadecls n in
- raise (Semantic_cocci.Semantic ("repeated rule name"))
- with Not_found -> ());
- Ast.CocciRulename (Some n,Ast.NoDep,[],[],Ast.Undetermined,false (*discarded*))
-
-let make_cocci_rule_name_result nm d i a e ee =
- match nm with
- Some nm ->
- let n = id2name nm in
- (try let _ = Hashtbl.find Data.all_metadecls n in
- raise (Semantic_cocci.Semantic ("repeated rule name"))
- with Not_found -> ());
- Ast.CocciRulename (Some n,d,i,a,e,ee)
- | None -> Ast.CocciRulename (None,d,i,a,e,ee)
-
-let make_generated_rule_name_result nm d i a e ee =
- match nm with
- Some nm ->
- let n = id2name nm in
- (try let _ = Hashtbl.find Data.all_metadecls n in
- raise (Semantic_cocci.Semantic ("repeated rule name"))
- with Not_found -> ());
- Ast.GeneratedRulename (Some n,d,i,a,e,ee)
- | None -> Ast.GeneratedRulename (None,d,i,a,e,ee)
-
-let make_script_rule_name_result lang deps =
- let l = id2name lang in
- Ast.ScriptRulename (l,deps)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* splits the entire file into minus and plus fragments, and parses each
-separately (thus duplicating work for the parsing of the context elements) *)
-
-module D = Data
-module PC = Parser_cocci_menhir
-module V0 = Visitor_ast0
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-let pr = Printf.sprintf
-(*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
-let pr2 s = Printf.printf "%s\n" s
-
-(* for isomorphisms. all should be at the front!!! *)
-let reserved_names =
- ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
-
-(* ----------------------------------------------------------------------- *)
-(* Debugging... *)
-
-let line_type (d,_,_,_,_,_,_,_) = d
-
-let line_type2c tok =
- match line_type tok with
- D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ":-"
- | D.PLUS -> ":+"
- | D.CONTEXT | D.UNIQUE | D.OPT -> ""
-
-let token2c (tok,_) =
- match tok with
- PC.TIdentifier -> "identifier"
- | PC.TType -> "type"
- | PC.TParameter -> "parameter"
- | PC.TConstant -> "constant"
- | PC.TExpression -> "expression"
- | PC.TIdExpression -> "idexpression"
- | PC.TStatement -> "statement"
- | PC.TPosition -> "position"
- | PC.TPosAny -> "any"
- | PC.TFunction -> "function"
- | PC.TLocal -> "local"
- | PC.Tlist -> "list"
- | PC.TFresh -> "fresh"
- | PC.TPure -> "pure"
- | PC.TContext -> "context"
- | PC.TTypedef -> "typedef"
- | PC.TDeclarer -> "declarer"
- | PC.TIterator -> "iterator"
- | PC.TName -> "name"
- | PC.TRuleName str -> "rule_name-"^str
- | PC.TUsing -> "using"
- | PC.TPathIsoFile str -> "path_iso_file-"^str
- | PC.TDisable -> "disable"
- | PC.TExtends -> "extends"
- | PC.TDepends -> "depends"
- | PC.TOn -> "on"
- | PC.TEver -> "ever"
- | PC.TNever -> "never"
- | PC.TExists -> "exists"
- | PC.TForall -> "forall"
- | PC.TReverse -> "reverse"
- | PC.TError -> "error"
- | PC.TWords -> "words"
- | PC.TGenerated -> "generated"
-
- | PC.TNothing -> "nothing"
-
- | PC.Tchar(clt) -> "char"^(line_type2c clt)
- | PC.Tshort(clt) -> "short"^(line_type2c clt)
- | PC.Tint(clt) -> "int"^(line_type2c clt)
- | PC.Tdouble(clt) -> "double"^(line_type2c clt)
- | PC.Tfloat(clt) -> "float"^(line_type2c clt)
- | PC.Tlong(clt) -> "long"^(line_type2c clt)
- | PC.Tvoid(clt) -> "void"^(line_type2c clt)
- | PC.Tstruct(clt) -> "struct"^(line_type2c clt)
- | PC.Tunion(clt) -> "union"^(line_type2c clt)
- | PC.Tenum(clt) -> "enum"^(line_type2c clt)
- | PC.Tunsigned(clt) -> "unsigned"^(line_type2c clt)
- | PC.Tsigned(clt) -> "signed"^(line_type2c clt)
- | PC.Tstatic(clt) -> "static"^(line_type2c clt)
- | PC.Tinline(clt) -> "inline"^(line_type2c clt)
- | PC.Ttypedef(clt) -> "typedef"^(line_type2c clt)
- | PC.Tattr(s,clt) -> s^(line_type2c clt)
- | PC.Tauto(clt) -> "auto"^(line_type2c clt)
- | PC.Tregister(clt) -> "register"^(line_type2c clt)
- | PC.Textern(clt) -> "extern"^(line_type2c clt)
- | PC.Tconst(clt) -> "const"^(line_type2c clt)
- | PC.Tvolatile(clt) -> "volatile"^(line_type2c clt)
-
- | PC.TPragma(s) -> s
- | PC.TIncludeL(s,clt) -> (pr "#include \"%s\"" s)^(line_type2c clt)
- | PC.TIncludeNL(s,clt) -> (pr "#include <%s>" s)^(line_type2c clt)
- | PC.TDefine(clt,_) -> "#define"^(line_type2c clt)
- | PC.TDefineParam(clt,_,_) -> "#define_param"^(line_type2c clt)
- | PC.TMinusFile(s,clt) -> (pr "--- %s" s)^(line_type2c clt)
- | PC.TPlusFile(s,clt) -> (pr "+++ %s" s)^(line_type2c clt)
-
- | PC.TInc(clt) -> "++"^(line_type2c clt)
- | PC.TDec(clt) -> "--"^(line_type2c clt)
-
- | PC.TIf(clt) -> "if"^(line_type2c clt)
- | PC.TElse(clt) -> "else"^(line_type2c clt)
- | PC.TWhile(clt) -> "while"^(line_type2c clt)
- | PC.TFor(clt) -> "for"^(line_type2c clt)
- | PC.TDo(clt) -> "do"^(line_type2c clt)
- | PC.TSwitch(clt) -> "switch"^(line_type2c clt)
- | PC.TCase(clt) -> "case"^(line_type2c clt)
- | PC.TDefault(clt) -> "default"^(line_type2c clt)
- | PC.TReturn(clt) -> "return"^(line_type2c clt)
- | PC.TBreak(clt) -> "break"^(line_type2c clt)
- | PC.TContinue(clt) -> "continue"^(line_type2c clt)
- | PC.TGoto(clt) -> "goto"^(line_type2c clt)
- | PC.TIdent(s,clt) -> (pr "ident-%s" s)^(line_type2c clt)
- | PC.TTypeId(s,clt) -> (pr "typename-%s" s)^(line_type2c clt)
- | PC.TDeclarerId(s,clt) -> (pr "declarername-%s" s)^(line_type2c clt)
- | PC.TIteratorId(s,clt) -> (pr "iteratorname-%s" s)^(line_type2c clt)
- | PC.TMetaDeclarer(_,_,_,clt) -> "declmeta"^(line_type2c clt)
- | PC.TMetaIterator(_,_,_,clt) -> "itermeta"^(line_type2c clt)
-
- | PC.TSizeof(clt) -> "sizeof"^(line_type2c clt)
-
- | PC.TString(x,clt) -> x^(line_type2c clt)
- | PC.TChar(x,clt) -> x^(line_type2c clt)
- | PC.TFloat(x,clt) -> x^(line_type2c clt)
- | PC.TInt(x,clt) -> x^(line_type2c clt)
-
- | PC.TOrLog(clt) -> "||"^(line_type2c clt)
- | PC.TAndLog(clt) -> "&&"^(line_type2c clt)
- | PC.TOr(clt) -> "|"^(line_type2c clt)
- | PC.TXor(clt) -> "^"^(line_type2c clt)
- | PC.TAnd (clt) -> "&"^(line_type2c clt)
- | PC.TEqEq(clt) -> "=="^(line_type2c clt)
- | PC.TNotEq(clt) -> "!="^(line_type2c clt)
- | PC.TLogOp(op,clt) ->
- (match op with
- Ast.Inf -> "<"
- | Ast.InfEq -> "<="
- | Ast.Sup -> ">"
- | Ast.SupEq -> ">="
- | _ -> failwith "not possible")
- ^(line_type2c clt)
- | PC.TShOp(op,clt) ->
- (match op with
- Ast.DecLeft -> "<<"
- | Ast.DecRight -> ">>"
- | _ -> failwith "not possible")
- ^(line_type2c clt)
- | PC.TPlus(clt) -> "+"^(line_type2c clt)
- | PC.TMinus(clt) -> "-"^(line_type2c clt)
- | PC.TMul(clt) -> "*"^(line_type2c clt)
- | PC.TDmOp(op,clt) ->
- (match op with
- Ast.Div -> "/"
- | Ast.Mod -> "%"
- | _ -> failwith "not possible")
- ^(line_type2c clt)
- | PC.TTilde (clt) -> "~"^(line_type2c clt)
-
- | PC.TMetaParam(_,_,clt) -> "parammeta"^(line_type2c clt)
- | PC.TMetaParamList(_,_,_,clt) -> "paramlistmeta"^(line_type2c clt)
- | PC.TMetaConst(_,_,_,_,clt) -> "constmeta"^(line_type2c clt)
- | PC.TMetaErr(_,_,_,clt) -> "errmeta"^(line_type2c clt)
- | PC.TMetaExp(_,_,_,_,clt) -> "expmeta"^(line_type2c clt)
- | PC.TMetaIdExp(_,_,_,_,clt) -> "idexpmeta"^(line_type2c clt)
- | PC.TMetaLocalIdExp(_,_,_,_,clt) -> "localidexpmeta"^(line_type2c clt)
- | PC.TMetaExpList(_,_,_,clt) -> "explistmeta"^(line_type2c clt)
- | PC.TMetaId(_,_,_,clt) -> "idmeta"^(line_type2c clt)
- | PC.TMetaType(_,_,clt) -> "typemeta"^(line_type2c clt)
- | PC.TMetaStm(_,_,clt) -> "stmmeta"^(line_type2c clt)
- | PC.TMetaStmList(_,_,clt) -> "stmlistmeta"^(line_type2c clt)
- | PC.TMetaFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt)
- | PC.TMetaLocalFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt)
- | PC.TMetaPos(_,_,_,clt) -> "posmeta"
- | PC.TMPtVirg -> ";"
- | PC.TArobArob -> "@@"
- | PC.TArob -> "@"
- | PC.TPArob -> "P@"
- | PC.TScript -> "script"
-
- | PC.TWhen(clt) -> "WHEN"^(line_type2c clt)
- | PC.TWhenTrue(clt) -> "WHEN TRUE"^(line_type2c clt)
- | PC.TWhenFalse(clt) -> "WHEN FALSE"^(line_type2c clt)
- | PC.TAny(clt) -> "ANY"^(line_type2c clt)
- | PC.TStrict(clt) -> "STRICT"^(line_type2c clt)
- | PC.TEllipsis(clt) -> "..."^(line_type2c clt)
-(*
- | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
- | PC.TStars(clt) -> "***"^(line_type2c clt)
-*)
-
- | PC.TOEllipsis(clt) -> "<..."^(line_type2c clt)
- | PC.TCEllipsis(clt) -> "...>"^(line_type2c clt)
- | PC.TPOEllipsis(clt) -> "<+..."^(line_type2c clt)
- | PC.TPCEllipsis(clt) -> "...+>"^(line_type2c clt)
-(*
- | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
- | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
- | PC.TOStars(clt) -> "<***"^(line_type2c clt)
- | PC.TCStars(clt) -> "***>"^(line_type2c clt)
-*)
- | PC.TBang0 -> "!"
- | PC.TPlus0 -> "+"
- | PC.TWhy0 -> "?"
-
- | PC.TWhy(clt) -> "?"^(line_type2c clt)
- | PC.TDotDot(clt) -> ":"^(line_type2c clt)
- | PC.TBang(clt) -> "!"^(line_type2c clt)
- | PC.TOPar(clt) -> "("^(line_type2c clt)
- | PC.TOPar0(clt) -> "("^(line_type2c clt)
- | PC.TMid0(clt) -> "|"^(line_type2c clt)
- | PC.TCPar(clt) -> ")"^(line_type2c clt)
- | PC.TCPar0(clt) -> ")"^(line_type2c clt)
-
- | PC.TOBrace(clt) -> "{"^(line_type2c clt)
- | PC.TCBrace(clt) -> "}"^(line_type2c clt)
- | PC.TOCro(clt) -> "["^(line_type2c clt)
- | PC.TCCro(clt) -> "]"^(line_type2c clt)
- | PC.TOInit(clt) -> "{"^(line_type2c clt)
-
- | PC.TPtrOp(clt) -> "->"^(line_type2c clt)
-
- | PC.TEq(clt) -> "="^(line_type2c clt)
- | PC.TAssign(_,clt) -> "=op"^(line_type2c clt)
- | PC.TDot(clt) -> "."^(line_type2c clt)
- | PC.TComma(clt) -> ","^(line_type2c clt)
- | PC.TPtVirg(clt) -> ";"^(line_type2c clt)
-
- | PC.EOF -> "eof"
- | PC.TLineEnd(clt) -> "line end"
- | PC.TInvalid -> "invalid"
- | PC.TFunDecl(clt) -> "fundecl"
-
- | PC.TIso -> "<=>"
- | PC.TRightIso -> "=>"
- | PC.TIsoTopLevel -> "TopLevel"
- | PC.TIsoExpression -> "Expression"
- | PC.TIsoArgExpression -> "ArgExpression"
- | PC.TIsoTestExpression -> "TestExpression"
- | PC.TIsoStatement -> "Statement"
- | PC.TIsoDeclaration -> "Declaration"
- | PC.TIsoType -> "Type"
- | PC.TScriptData s -> s
-
-let print_tokens s tokens =
- Printf.printf "%s\n" s;
- List.iter (function x -> Printf.printf "%s " (token2c x)) tokens;
- Printf.printf "\n\n";
- flush stdout
-
-type plus = PLUS | NOTPLUS | SKIP
-
-let plus_attachable (tok,_) =
- match tok with
- PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt)
- | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt)
- | PC.Tauto(clt) | PC.Tregister(clt)
- | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt)
-
- | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_)
- | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt)
-
- | PC.TInc(clt) | PC.TDec(clt)
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
- | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
-
- | PC.TSizeof(clt)
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt)
-
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt)
- | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
- | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt)
- | PC.TMetaType(_,_,clt) | PC.TMetaStm(_,_,clt)
- | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
- | PC.TMetaLocalFunc(_,_,_,clt)
-
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
- | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
- (* | PC.TCircles(clt) | PC.TStars(clt) *)
-
- | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
- | PC.TCPar(clt)
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
- | PC.TOInit(clt)
-
- | PC.TPtrOp(clt)
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) ->
- if line_type clt = D.PLUS then PLUS else NOTPLUS
-
- | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
- | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
- | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt)
- | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
- | PC.TMetaPos(nm,_,_,_) -> NOTPLUS
-
- | _ -> SKIP
-
-let get_clt (tok,_) =
- match tok with
- PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt)
- | PC.Tinline(clt) | PC.Tattr(_,clt) | PC.Tauto(clt) | PC.Tregister(clt)
- | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt)
-
- | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_)
- | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt)
-
- | PC.TInc(clt) | PC.TDec(clt)
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
- | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
-
- | PC.TSizeof(clt)
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt)
-
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt)
- | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
- | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt)
- | PC.TMetaType(_,_,clt) | PC.TMetaStm(_,_,clt)
- | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
- | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt)
-
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) |
- PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
- (* | PC.TCircles(clt) | PC.TStars(clt) *)
-
- | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
- | PC.TCPar(clt)
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
- | PC.TOInit(clt)
-
- | PC.TPtrOp(clt)
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt)
-
- | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
- | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
- | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt)
- | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
-
- | _ -> failwith "no clt"
-
-let update_clt (tok,x) clt =
- match tok with
- PC.Tchar(_) -> (PC.Tchar(clt),x)
- | PC.Tshort(_) -> (PC.Tshort(clt),x)
- | PC.Tint(_) -> (PC.Tint(clt),x)
- | PC.Tdouble(_) -> (PC.Tdouble(clt),x)
- | PC.Tfloat(_) -> (PC.Tfloat(clt),x)
- | PC.Tlong(_) -> (PC.Tlong(clt),x)
- | PC.Tvoid(_) -> (PC.Tvoid(clt),x)
- | PC.Tstruct(_) -> (PC.Tstruct(clt),x)
- | PC.Tunion(_) -> (PC.Tunion(clt),x)
- | PC.Tenum(_) -> (PC.Tenum(clt),x)
- | PC.Tunsigned(_) -> (PC.Tunsigned(clt),x)
- | PC.Tsigned(_) -> (PC.Tsigned(clt),x)
- | PC.Tstatic(_) -> (PC.Tstatic(clt),x)
- | PC.Tinline(_) -> (PC.Tinline(clt),x)
- | PC.Ttypedef(_) -> (PC.Ttypedef(clt),x)
- | PC.Tattr(s,_) -> (PC.Tattr(s,clt),x)
- | PC.Tauto(_) -> (PC.Tauto(clt),x)
- | PC.Tregister(_) -> (PC.Tregister(clt),x)
- | PC.Textern(_) -> (PC.Textern(clt),x)
- | PC.Tconst(_) -> (PC.Tconst(clt),x)
- | PC.Tvolatile(_) -> (PC.Tvolatile(clt),x)
-
- | PC.TIncludeL(s,_) -> (PC.TIncludeL(s,clt),x)
- | PC.TIncludeNL(s,_) -> (PC.TIncludeNL(s,clt),x)
- | PC.TDefine(_,a) -> (PC.TDefine(clt,a),x)
- | PC.TDefineParam(_,a,b) -> (PC.TDefineParam(clt,a,b),x)
- | PC.TMinusFile(s,_) -> (PC.TMinusFile(s,clt),x)
- | PC.TPlusFile(s,_) -> (PC.TPlusFile(s,clt),x)
-
- | PC.TInc(_) -> (PC.TInc(clt),x)
- | PC.TDec(_) -> (PC.TDec(clt),x)
-
- | PC.TIf(_) -> (PC.TIf(clt),x)
- | PC.TElse(_) -> (PC.TElse(clt),x)
- | PC.TWhile(_) -> (PC.TWhile(clt),x)
- | PC.TFor(_) -> (PC.TFor(clt),x)
- | PC.TDo(_) -> (PC.TDo(clt),x)
- | PC.TSwitch(_) -> (PC.TSwitch(clt),x)
- | PC.TCase(_) -> (PC.TCase(clt),x)
- | PC.TDefault(_) -> (PC.TDefault(clt),x)
- | PC.TReturn(_) -> (PC.TReturn(clt),x)
- | PC.TBreak(_) -> (PC.TBreak(clt),x)
- | PC.TContinue(_) -> (PC.TContinue(clt),x)
- | PC.TGoto(_) -> (PC.TGoto(clt),x)
- | PC.TIdent(s,_) -> (PC.TIdent(s,clt),x)
- | PC.TTypeId(s,_) -> (PC.TTypeId(s,clt),x)
- | PC.TDeclarerId(s,_) -> (PC.TDeclarerId(s,clt),x)
- | PC.TIteratorId(s,_) -> (PC.TIteratorId(s,clt),x)
-
- | PC.TSizeof(_) -> (PC.TSizeof(clt),x)
-
- | PC.TString(s,_) -> (PC.TString(s,clt),x)
- | PC.TChar(s,_) -> (PC.TChar(s,clt),x)
- | PC.TFloat(s,_) -> (PC.TFloat(s,clt),x)
- | PC.TInt(s,_) -> (PC.TInt(s,clt),x)
-
- | PC.TOrLog(_) -> (PC.TOrLog(clt),x)
- | PC.TAndLog(_) -> (PC.TAndLog(clt),x)
- | PC.TOr(_) -> (PC.TOr(clt),x)
- | PC.TXor(_) -> (PC.TXor(clt),x)
- | PC.TAnd (_) -> (PC.TAnd (clt),x)
- | PC.TEqEq(_) -> (PC.TEqEq(clt),x)
- | PC.TNotEq(_) -> (PC.TNotEq(clt),x)
- | PC.TLogOp(op,_) -> (PC.TLogOp(op,clt),x)
- | PC.TShOp(op,_) -> (PC.TShOp(op,clt),x)
- | PC.TPlus(_) -> (PC.TPlus(clt),x)
- | PC.TMinus(_) -> (PC.TMinus(clt),x)
- | PC.TMul(_) -> (PC.TMul(clt),x)
- | PC.TDmOp(op,_) -> (PC.TDmOp(op,clt),x)
- | PC.TTilde (_) -> (PC.TTilde (clt),x)
-
- | PC.TMetaParam(a,b,_) -> (PC.TMetaParam(a,b,clt),x)
- | PC.TMetaParamList(a,b,c,_) -> (PC.TMetaParamList(a,b,c,clt),x)
- | PC.TMetaConst(a,b,c,d,_) -> (PC.TMetaConst(a,b,c,d,clt),x)
- | PC.TMetaErr(a,b,c,_) -> (PC.TMetaErr(a,b,c,clt),x)
- | PC.TMetaExp(a,b,c,d,_) -> (PC.TMetaExp(a,b,c,d,clt),x)
- | PC.TMetaIdExp(a,b,c,d,_) -> (PC.TMetaIdExp(a,b,c,d,clt),x)
- | PC.TMetaLocalIdExp(a,b,c,d,_) -> (PC.TMetaLocalIdExp(a,b,c,d,clt),x)
- | PC.TMetaExpList(a,b,c,_) -> (PC.TMetaExpList(a,b,c,clt),x)
- | PC.TMetaId(a,b,c,_) -> (PC.TMetaId(a,b,c,clt),x)
- | PC.TMetaType(a,b,_) -> (PC.TMetaType(a,b,clt),x)
- | PC.TMetaStm(a,b,_) -> (PC.TMetaStm(a,b,clt),x)
- | PC.TMetaStmList(a,b,_) -> (PC.TMetaStmList(a,b,clt),x)
- | PC.TMetaFunc(a,b,c,_) -> (PC.TMetaFunc(a,b,c,clt),x)
- | PC.TMetaLocalFunc(a,b,c,_) -> (PC.TMetaLocalFunc(a,b,c,clt),x)
-
- | PC.TWhen(_) -> (PC.TWhen(clt),x)
- | PC.TWhenTrue(_) -> (PC.TWhenTrue(clt),x)
- | PC.TWhenFalse(_) -> (PC.TWhenFalse(clt),x)
- | PC.TAny(_) -> (PC.TAny(clt),x)
- | PC.TStrict(_) -> (PC.TStrict(clt),x)
- | PC.TEllipsis(_) -> (PC.TEllipsis(clt),x)
-(*
- | PC.TCircles(_) -> (PC.TCircles(clt),x)
- | PC.TStars(_) -> (PC.TStars(clt),x)
-*)
-
- | PC.TOEllipsis(_) -> (PC.TOEllipsis(clt),x)
- | PC.TCEllipsis(_) -> (PC.TCEllipsis(clt),x)
- | PC.TPOEllipsis(_) -> (PC.TPOEllipsis(clt),x)
- | PC.TPCEllipsis(_) -> (PC.TPCEllipsis(clt),x)
-(*
- | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
- | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
- | PC.TOStars(_) -> (PC.TOStars(clt),x)
- | PC.TCStars(_) -> (PC.TCStars(clt),x)
-*)
-
- | PC.TWhy(_) -> (PC.TWhy(clt),x)
- | PC.TDotDot(_) -> (PC.TDotDot(clt),x)
- | PC.TBang(_) -> (PC.TBang(clt),x)
- | PC.TOPar(_) -> (PC.TOPar(clt),x)
- | PC.TOPar0(_) -> (PC.TOPar0(clt),x)
- | PC.TMid0(_) -> (PC.TMid0(clt),x)
- | PC.TCPar(_) -> (PC.TCPar(clt),x)
- | PC.TCPar0(_) -> (PC.TCPar0(clt),x)
-
- | PC.TOBrace(_) -> (PC.TOBrace(clt),x)
- | PC.TCBrace(_) -> (PC.TCBrace(clt),x)
- | PC.TOCro(_) -> (PC.TOCro(clt),x)
- | PC.TCCro(_) -> (PC.TCCro(clt),x)
- | PC.TOInit(_) -> (PC.TOInit(clt),x)
-
- | PC.TPtrOp(_) -> (PC.TPtrOp(clt),x)
-
- | PC.TEq(_) -> (PC.TEq(clt),x)
- | PC.TAssign(s,_) -> (PC.TAssign(s,clt),x)
- | PC.TDot(_) -> (PC.TDot(clt),x)
- | PC.TComma(_) -> (PC.TComma(clt),x)
- | PC.TPtVirg(_) -> (PC.TPtVirg(clt),x)
-
- | PC.TLineEnd(_) -> (PC.TLineEnd(clt),x)
- | PC.TFunDecl(_) -> (PC.TFunDecl(clt),x)
-
- | _ -> failwith "no clt"
-
-
-(* ----------------------------------------------------------------------- *)
-
-let make_name prefix ln = Printf.sprintf "%s starting on line %d" prefix ln
-
-(* ----------------------------------------------------------------------- *)
-(* Read tokens *)
-
-let wrap_lexbuf_info lexbuf =
- (Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf)
-
-let tokens_all_full token table file get_ats lexbuf end_markers :
- (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
- try
- let rec aux () =
- let result = token lexbuf in
- let info = (Lexing.lexeme lexbuf,
- (table.(Lexing.lexeme_start lexbuf)),
- (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) in
- if result = PC.EOF
- then
- if get_ats
- then failwith "unexpected end of file in a metavariable declaration"
- else (false,[(result,info)])
- else if List.mem result end_markers
- then (true,[(result,info)])
- else
- let (more,rest) = aux() in
- (more,(result, info)::rest)
- in aux ()
- with
- e -> pr2 (Common.error_message file (wrap_lexbuf_info lexbuf) ); raise e
-
-let tokens_all table file get_ats lexbuf end_markers :
- (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
- tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
-
-let tokens_script_all table file get_ats lexbuf end_markers :
- (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
- tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
-
-(* ----------------------------------------------------------------------- *)
-(* Split tokens into minus and plus fragments *)
-
-let split t clt =
- let (d,_,_,_,_,_,_,_) = clt in
- match d with
- D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ([t],[])
- | D.PLUS -> ([],[t])
- | D.CONTEXT | D.UNIQUE | D.OPT -> ([t],[t])
-
-let split_token ((tok,_) as t) =
- match tok with
- PC.TIdentifier | PC.TConstant | PC.TExpression | PC.TIdExpression
- | PC.TStatement | PC.TPosition | PC.TPosAny
- | PC.TFunction | PC.TTypedef | PC.TDeclarer | PC.TIterator | PC.TName
- | PC.TType | PC.TParameter | PC.TLocal | PC.Tlist | PC.TFresh | PC.TPure
- | PC.TContext | PC.TRuleName(_) | PC.TUsing | PC.TDisable | PC.TExtends
- | PC.TPathIsoFile(_)
- | PC.TDepends | PC.TOn | PC.TEver | PC.TNever | PC.TExists | PC.TForall
- | PC.TReverse
- | PC.TError | PC.TWords | PC.TGenerated | PC.TNothing -> ([t],[t])
-
- | PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt)
- | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt)
- | PC.Tconst(clt) | PC.Tvolatile(clt) -> split t clt
-
- | PC.TPragma(s) -> ([],[t]) (* only allowed in + *)
- | PC.TPlusFile(s,clt) | PC.TMinusFile(s,clt)
- | PC.TIncludeL(s,clt) | PC.TIncludeNL(s,clt) ->
- split t clt
- | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_) -> split t clt
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt)
- | PC.TSizeof(clt)
- | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
- | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
- | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt)
- | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaErr(_,_,_,clt)
- | PC.TMetaFunc(_,_,_,clt) | PC.TMetaLocalFunc(_,_,_,clt)
- | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt) -> split t clt
- | PC.TMPtVirg | PC.TArob | PC.TArobArob | PC.TScript -> ([t],[t])
- | PC.TPArob | PC.TMetaPos(_,_,_,_) -> ([t],[])
-
- | PC.TFunDecl(clt)
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
- | PC.TAny(clt) | PC.TStrict(clt) | PC.TLineEnd(clt)
- | PC.TEllipsis(clt) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
-
- | PC.TOEllipsis(_) | PC.TCEllipsis(_) (* clt must be context *)
- | PC.TPOEllipsis(_) | PC.TPCEllipsis(_) (* clt must be context *)
-(*
- | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
- | PC.TOStars(_) | PC.TCStars(_) (* clt must be context *)
-*)
- | PC.TBang0 | PC.TPlus0 | PC.TWhy0 ->
- ([t],[t])
-
- | PC.TWhy(clt) | PC.TDotDot(clt)
- | PC.TBang(clt) | PC.TOPar(clt) | PC.TOPar0(clt)
- | PC.TMid0(clt) | PC.TCPar(clt) | PC.TCPar0(clt) -> split t clt
-
- | PC.TInc(clt) | PC.TDec(clt) -> split t clt
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) ->
- split t clt
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt) -> split t clt
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOInit(clt) -> split t clt
- | PC.TOCro(clt) | PC.TCCro(clt) -> split t clt
-
- | PC.TPtrOp(clt) -> split t clt
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) -> split t clt
-
- | PC.EOF | PC.TInvalid -> ([t],[t])
-
- | PC.TIso | PC.TRightIso
- | PC.TIsoExpression | PC.TIsoStatement | PC.TIsoDeclaration | PC.TIsoType
- | PC.TIsoTopLevel | PC.TIsoArgExpression | PC.TIsoTestExpression ->
- failwith "unexpected tokens"
- | PC.TScriptData s -> ([t],[t])
-
-let split_token_stream tokens =
- let rec loop = function
- [] -> ([],[])
- | token::tokens ->
- let (minus,plus) = split_token token in
- let (minus_stream,plus_stream) = loop tokens in
- (minus@minus_stream,plus@plus_stream) in
- loop tokens
-
-(* ----------------------------------------------------------------------- *)
-(* Find function names *)
-(* This addresses a shift-reduce problem in the parser, allowing us to
-distinguish a function declaration from a function call even if the latter
-has no return type. Undoubtedly, this is not very nice, but it doesn't
-seem very convenient to refactor the grammar to get around the problem. *)
-
-let rec find_function_names = function
- [] -> []
- | ((PC.TIdent(_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaId(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaFunc(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaLocalFunc(_,_,_,clt),info) as t1)::((PC.TOPar(_),_) as t2)::rest
- ->
- let rec skip level = function
- [] -> ([],false,[])
- | ((PC.TCPar(_),_) as t)::rest ->
- let level = level - 1 in
- if level = 0
- then ([t],true,rest)
- else let (pre,found,post) = skip level rest in (t::pre,found,post)
- | ((PC.TOPar(_),_) as t)::rest ->
- let level = level + 1 in
- let (pre,found,post) = skip level rest in (t::pre,found,post)
- | ((PC.TArobArob,_) as t)::rest
- | ((PC.TArob,_) as t)::rest
- | ((PC.EOF,_) as t)::rest -> ([t],false,rest)
- | t::rest ->
- let (pre,found,post) = skip level rest in (t::pre,found,post) in
- let (pre,found,post) = skip 1 rest in
- (match (found,post) with
- (true,((PC.TOBrace(_),_) as t3)::rest) ->
- (PC.TFunDecl(clt),info) :: t1 :: t2 :: pre @
- t3 :: (find_function_names rest)
- | _ -> t1 :: t2 :: pre @ find_function_names post)
- | t :: rest -> t :: find_function_names rest
-
-(* ----------------------------------------------------------------------- *)
-(* an attribute is an identifier that preceeds another identifier and
- begins with __ *)
-
-let rec detect_attr l =
- let is_id = function
- (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
- | (PC.TMetaLocalFunc(_,_,_,_),_) -> true
- | _ -> false in
- let rec loop = function
- [] -> []
- | [x] -> [x]
- | ((PC.TIdent(nm,clt),info) as t1)::id::rest when is_id id ->
- if String.length nm > 2 && String.sub nm 0 2 = "__"
- then (PC.Tattr(nm,clt),info)::(loop (id::rest))
- else t1::(loop (id::rest))
- | x::xs -> x::(loop xs) in
- loop l
-
-(* ----------------------------------------------------------------------- *)
-(* Look for variable declarations where the name is a typedef name.
-We assume that C code does not contain a multiplication as a top-level
-statement. *)
-
-(* bug: once a type, always a type, even if the same name is later intended
- to be used as a real identifier *)
-let detect_types in_meta_decls l =
- let is_delim infn = function
- (PC.TOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
- | (PC.TPOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
- | (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
- | (PC.TPtVirg(_),_) | (PC.TOBrace(_),_) | (PC.TOInit(_),_)
- | (PC.TCBrace(_),_)
- | (PC.TPure,_) | (PC.TContext,_)
- | (PC.Tstatic(_),_) | (PC.Textern(_),_)
- | (PC.Tinline(_),_) | (PC.Ttypedef(_),_) | (PC.Tattr(_),_) -> true
- | (PC.TComma(_),_) when infn > 0 or in_meta_decls -> true
- | (PC.TDotDot(_),_) when in_meta_decls -> true
- | _ -> false in
- let is_choices_delim = function
- (PC.TOBrace(_),_) | (PC.TComma(_),_) -> true | _ -> false in
- let is_id = function
- (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
- | (PC.TMetaLocalFunc(_,_,_,_),_) -> true
- | (PC.TMetaParam(_,_,_),_)
- | (PC.TMetaParamList(_,_,_,_),_)
- | (PC.TMetaConst(_,_,_,_,_),_)
- | (PC.TMetaErr(_,_,_,_),_)
- | (PC.TMetaExp(_,_,_,_,_),_)
- | (PC.TMetaIdExp(_,_,_,_,_),_)
- | (PC.TMetaLocalIdExp(_,_,_,_,_),_)
- | (PC.TMetaExpList(_,_,_,_),_)
- | (PC.TMetaType(_,_,_),_)
- | (PC.TMetaStm(_,_,_),_)
- | (PC.TMetaStmList(_,_,_),_)
- | (PC.TMetaPos(_,_,_,_),_) -> in_meta_decls
- | _ -> false in
- let redo_id ident clt v =
- !Data.add_type_name ident;
- (PC.TTypeId(ident,clt),v) in
- let rec loop start infn type_names = function
- (* infn: 0 means not in a function header
- > 0 means in a function header, after infn - 1 unmatched open parens*)
- [] -> []
- | ((PC.TOBrace(clt),v)::_) as all when in_meta_decls ->
- collect_choices type_names all (* never a function header *)
- | delim::(PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest
- when is_delim infn delim ->
- let newid = redo_id ident clt v in
- delim::newid::x::(loop false infn (ident::type_names) rest)
- | delim::(PC.TIdent(ident,clt),v)::id::rest
- when is_delim infn delim && is_id id ->
- let newid = redo_id ident clt v in
- delim::newid::id::(loop false infn (ident::type_names) rest)
- | ((PC.TFunDecl(_),_) as fn)::rest ->
- fn::(loop false 1 type_names rest)
- | ((PC.TOPar(_),_) as lp)::rest when infn > 0 ->
- lp::(loop false (infn + 1) type_names rest)
- | ((PC.TCPar(_),_) as rp)::rest when infn > 0 ->
- if infn - 1 = 1
- then rp::(loop false 0 type_names rest) (* 0 means not in fn header *)
- else rp::(loop false (infn - 1) type_names rest)
- | (PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest when start ->
- let newid = redo_id ident clt v in
- newid::x::(loop false infn (ident::type_names) rest)
- | (PC.TIdent(ident,clt),v)::id::rest when start && is_id id ->
- let newid = redo_id ident clt v in
- newid::id::(loop false infn (ident::type_names) rest)
- | (PC.TIdent(ident,clt),v)::rest when List.mem ident type_names ->
- (PC.TTypeId(ident,clt),v)::(loop false infn type_names rest)
- | ((PC.TIdent(ident,clt),v) as x)::rest ->
- x::(loop false infn type_names rest)
- | x::rest -> x::(loop false infn type_names rest)
- and collect_choices type_names = function
- [] -> [] (* should happen, but let the parser detect that *)
- | (PC.TCBrace(clt),v)::rest ->
- (PC.TCBrace(clt),v)::(loop false 0 type_names rest)
- | delim::(PC.TIdent(ident,clt),v)::rest
- when is_choices_delim delim ->
- let newid = redo_id ident clt v in
- delim::newid::(collect_choices (ident::type_names) rest)
- | x::rest -> x::(collect_choices type_names rest) in
- loop true 0 [] l
-
-
-(* ----------------------------------------------------------------------- *)
-(* Insert TLineEnd tokens at the end of a line that contains a WHEN.
- WHEN is restricted to a single line, to avoid ambiguity in eg:
- ... WHEN != x
- +3 *)
-
-let token2line (tok,_) =
- match tok with
- PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt)
- | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt) | PC.Tconst(clt)
- | PC.Tvolatile(clt)
-
- | PC.TInc(clt) | PC.TDec(clt)
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch (clt) | PC.TCase (clt) | PC.TDefault (clt) | PC.TSizeof (clt)
- | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
- | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
- | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt)
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt)
-
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
- | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt)
- | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
- | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt)
-
- | PC.TFunDecl(clt)
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
- | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
- (* | PC.TCircles(clt) | PC.TStars(clt) *)
-
- | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
- | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (*| PC.TOCircles(clt)
- | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
-
- | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
- | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar(clt)
- | PC.TCPar0(clt)
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
- | PC.TOInit(clt)
-
- | PC.TPtrOp(clt)
-
- | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_)
- | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt)
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) ->
- let (_,line,_,_,_,_,_,_) = clt in Some line
-
- | _ -> None
-
-let rec insert_line_end = function
- [] -> []
- | (((PC.TWhen(clt),q) as x)::xs) ->
- x::(find_line_end true (token2line x) clt q xs)
- | (((PC.TDefine(clt,_),q) as x)::xs)
- | (((PC.TDefineParam(clt,_,_),q) as x)::xs) ->
- x::(find_line_end false (token2line x) clt q xs)
- | x::xs -> x::(insert_line_end xs)
-
-and find_line_end inwhen line clt q = function
- (* don't know what 2nd component should be so just use the info of
- the When. Also inherit - of when, if any *)
- [] -> [(PC.TLineEnd(clt),q)]
- | ((PC.TIdent("strict",clt),a) as x)::xs when token2line x = line ->
- (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("STRICT",clt),a) as x)::xs when token2line x = line ->
- (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("any",clt),a) as x)::xs when token2line x = line ->
- (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("ANY",clt),a) as x)::xs when token2line x = line ->
- (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("forall",clt),a) as x)::xs when token2line x = line ->
- (PC.TForall,a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("exists",clt),a) as x)::xs when token2line x = line ->
- (PC.TExists,a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TComma(clt),a) as x)::xs when token2line x = line ->
- (PC.TComma(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TPArob,a) as x)::xs -> (* no line #, just assume on the same line *)
- x :: (find_line_end inwhen line clt q xs)
- | x::xs when token2line x = line -> x :: (find_line_end inwhen line clt q xs)
- | xs -> (PC.TLineEnd(clt),q)::(insert_line_end xs)
-
-let rec translate_when_true_false = function
- [] -> []
- | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("true",_),_)::xs ->
- (PC.TWhenTrue(clt),q)::x::(translate_when_true_false xs)
- | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("false",_),_)::xs ->
- (PC.TWhenFalse(clt),q)::x::(translate_when_true_false xs)
- | x::xs -> x :: (translate_when_true_false xs)
-
-(* ----------------------------------------------------------------------- *)
-(* top level initializers: a sequence of braces followed by a dot *)
-
-let find_top_init tokens =
- match tokens with
- (PC.TOBrace(clt),q) :: rest ->
- let rec dot_start acc = function
- ((PC.TOBrace(_),_) as x) :: rest ->
- dot_start (x::acc) rest
- | ((PC.TDot(_),_) :: rest) as x ->
- Some ((PC.TOInit(clt),q) :: (List.rev acc) @ x)
- | l -> None in
- let rec comma_end acc = function
- ((PC.TCBrace(_),_) as x) :: rest ->
- comma_end (x::acc) rest
- | ((PC.TComma(_),_) :: rest) as x ->
- Some ((PC.TOInit(clt),q) :: (List.rev x) @ acc)
- | l -> None in
- (match dot_start [] rest with
- Some x -> x
- | None ->
- (match List.rev rest with
- (* not super sure what this does, but EOF, @, and @@ should be
- the same, markind the end of a rule *)
- ((PC.EOF,_) as x)::rest | ((PC.TArob,_) as x)::rest
- | ((PC.TArobArob,_) as x)::rest ->
- (match comma_end [x] rest with
- Some x -> x
- | None -> tokens)
- | _ ->
- failwith "unexpected empty token list"))
- | _ -> tokens
-
-(* ----------------------------------------------------------------------- *)
-(* process pragmas: they can only be used in + code, and adjacent to
-another + token. They are concatenated to the string representation of
-that other token. *)
-
-let rec collect_all_pragmas collected = function
- (PC.TPragma(s),_)::rest -> collect_all_pragmas (s::collected) rest
- | l -> (List.rev collected,l)
-
-let rec collect_up_to_pragmas skipped = function
- [] -> None (* didn't reach a pragma, so nothing to do *)
- | ((PC.TPragma(s),_) as t)::rest ->
- let (pragmas,rest) = collect_all_pragmas [] (t::rest) in
- Some (List.rev skipped,pragmas,rest)
- | x::xs ->
- match plus_attachable x with
- PLUS -> None
- | NOTPLUS -> None
- | SKIP -> collect_up_to_pragmas (x::skipped) xs
-
-let rec collect_up_to_plus skipped = function
- [] -> failwith "nothing to attach a pragma to (empty)"
- | x::xs ->
- match plus_attachable x with
- PLUS -> (List.rev skipped,x,xs)
- | NOTPLUS -> failwith "nothing to attach a pragma to"
- | SKIP -> collect_up_to_plus (x::skipped) xs
-
-let rec process_pragmas = function
- [] -> []
- | ((PC.TPragma(s),_)::_) as l ->
- let (pragmas,rest) = collect_all_pragmas [] l in
- let (skipped,aft,rest) = collect_up_to_plus [] rest in
- let (a,b,c,d,e,strbef,straft,pos) = get_clt aft in
- skipped@
- (process_pragmas ((update_clt aft (a,b,c,d,e,pragmas,straft,pos))::rest))
- | bef::xs ->
- (match plus_attachable bef with
- PLUS ->
- (match collect_up_to_pragmas [] xs with
- Some(skipped,pragmas,rest) ->
- let (a,b,c,d,e,strbef,straft,pos) = get_clt bef in
- (update_clt bef (a,b,c,d,e,strbef,pragmas,pos))::
- skipped@(process_pragmas rest)
- | None -> bef::(process_pragmas xs))
- | _ -> bef::(process_pragmas xs))
-
-(* ----------------------------------------------------------------------- *)
-(* Drop ... ... . This is only allowed in + code, and arises when there is
-some - code between the ... *)
-(* drop whens as well - they serve no purpose in + code and they cause
-problems for drop_double_dots *)
-
-let rec drop_when = function
- [] -> []
- | (PC.TWhen(clt),info)::xs ->
- let rec loop = function
- [] -> []
- | (PC.TLineEnd(_),info)::xs -> drop_when xs
- | x::xs -> loop xs in
- loop xs
- | x::xs -> x::drop_when xs
-
-(* instead of dropping the double dots, we put TNothing in between them.
-these vanish after the parser, but keeping all the ...s in the + code makes
-it easier to align the + and - code in context_neg and in preparation for the
-isomorphisms. This shouldn't matter because the context code of the +
-slice is mostly ignored anyway *)
-let rec drop_double_dots l =
- let start = function
- (PC.TOEllipsis(_),_) | (PC.TPOEllipsis(_),_)
- (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
- true
- | _ -> false in
- let middle = function
- (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
- | _ -> false in
- let whenline = function
- (PC.TLineEnd(_),_) -> true
- | (PC.TMid0(_),_) -> true
- | _ -> false in
- let final = function
- (PC.TCEllipsis(_),_) | (PC.TPCEllipsis(_),_)
- (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
- true
- | _ -> false in
- let any_before x = start x or middle x or final x or whenline x in
- let any_after x = start x or middle x or final x in
- let rec loop ((_,i) as prev) = function
- [] -> []
- | x::rest when any_before prev && any_after x ->
- (PC.TNothing,i)::x::(loop x rest)
- | x::rest -> x :: (loop x rest) in
- match l with
- [] -> []
- | (x::xs) -> x :: loop x xs
-
-let rec fix f l =
- let cur = f l in
- if l = cur then l else fix f cur
-
-(* ( | ... | ) also causes parsing problems *)
-
-exception Not_empty
-
-let rec drop_empty_thing starter middle ender = function
- [] -> []
- | hd::rest when starter hd ->
- let rec loop = function
- x::rest when middle x -> loop rest
- | x::rest when ender x -> rest
- | _ -> raise Not_empty in
- (match try Some(loop rest) with Not_empty -> None with
- Some x -> drop_empty_thing starter middle ender x
- | None -> hd :: drop_empty_thing starter middle ender rest)
- | x::rest -> x :: drop_empty_thing starter middle ender rest
-
-let drop_empty_or =
- drop_empty_thing
- (function (PC.TOPar0(_),_) -> true | _ -> false)
- (function (PC.TMid0(_),_) -> true | _ -> false)
- (function (PC.TCPar0(_),_) -> true | _ -> false)
-
-let drop_empty_nest = drop_empty_thing
-
-(* ----------------------------------------------------------------------- *)
-(* Read tokens *)
-
-let get_s_starts (_, (s,_,(starts, ends))) =
- Printf.printf "%d %d\n" starts ends; (s, starts)
-
-let pop2 l =
- let v = List.hd !l in
- l := List.tl !l;
- v
-
-let reinit _ =
- PC.reinit (function _ -> PC.TArobArob (* a handy token *))
- (Lexing.from_function
- (function buf -> function n -> raise Common.Impossible))
-
-let parse_one str parsefn file toks =
- let all_tokens = ref toks in
- let cur_tok = ref (List.hd !all_tokens) in
-
- let lexer_function _ =
- let (v, info) = pop2 all_tokens in
- cur_tok := (v, info);
- v in
-
- let lexbuf_fake =
- Lexing.from_function
- (function buf -> function n -> raise Common.Impossible)
- in
-
- reinit();
-
- try parsefn lexer_function lexbuf_fake
- with
- Lexer_cocci.Lexical s ->
- failwith
- (Printf.sprintf "%s: lexical error: %s\n =%s\n" str s
- (Common.error_message file (get_s_starts !cur_tok) ))
- | Parser_cocci_menhir.Error ->
- failwith
- (Printf.sprintf "%s: parse error: \n = %s\n" str
- (Common.error_message file (get_s_starts !cur_tok) ))
- | Semantic_cocci.Semantic s ->
- failwith
- (Printf.sprintf "%s: semantic error: %s\n =%s\n" str s
- (Common.error_message file (get_s_starts !cur_tok) ))
-
- | e -> raise e
-
-let prepare_tokens tokens =
- find_top_init
- (translate_when_true_false (* after insert_line_end *)
- (insert_line_end
- (detect_types false (find_function_names (detect_attr tokens)))))
-
-let prepare_mv_tokens tokens =
- detect_types false (detect_attr tokens)
-
-let rec consume_minus_positions = function
- [] -> []
- | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs
- | ((PC.TMid0(_),_) as x)::xs -> x::consume_minus_positions xs
- | x::(PC.TPArob,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs ->
- let (arity,ln,lln,offset,col,strbef,straft,_) = get_clt x in
- let name = Parse_aux.clt2mcode name clt in
- let x =
- update_clt x
- (arity,ln,lln,offset,col,strbef,straft,
- Ast0.MetaPos(name,constraints,per)) in
- x::(consume_minus_positions xs)
- | x::xs -> x::consume_minus_positions xs
-
-let any_modif rule =
- let mcode x =
- match Ast0.get_mcode_mcodekind x with
- Ast0.MINUS _ | Ast0.PLUS -> true
- | _ -> false in
- let donothing r k e = k e in
- let bind x y = x or y in
- let option_default = false in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
- List.exists fn.V0.combiner_top_level rule
-
-let drop_last extra l = List.rev(extra@(List.tl(List.rev l)))
-
-let partition_either l =
- let rec part_either left right = function
- | [] -> (List.rev left, List.rev right)
- | x :: l ->
- (match x with
- | Common.Left e -> part_either (e :: left) right l
- | Common.Right e -> part_either left (e :: right) l) in
- part_either [] [] l
-
-let get_metavars parse_fn table file lexbuf =
- let rec meta_loop acc (* read one decl at a time *) =
- let (_,tokens) =
- tokens_all table file true lexbuf [PC.TArobArob;PC.TMPtVirg] in
- let tokens = prepare_mv_tokens tokens in
- match tokens with
- [(PC.TArobArob,_)] -> List.rev acc
- | _ ->
- let metavars = parse_one "meta" parse_fn file tokens in
- meta_loop (metavars@acc) in
- partition_either (meta_loop [])
-
-let get_script_metavars parse_fn table file lexbuf =
- let rec meta_loop acc =
- let (_, tokens) =
- tokens_all table file true lexbuf [PC.TArobArob; PC.TMPtVirg] in
- let tokens = prepare_tokens tokens in
- match tokens with
- [(PC.TArobArob, _)] -> List.rev acc
- | _ ->
- let metavar = parse_one "scriptmeta" parse_fn file tokens in
- meta_loop (metavar :: acc)
- in
- meta_loop []
-
-let get_rule_name parse_fn starts_with_name get_tokens file prefix =
- Data.in_rule_name := true;
- let mknm _ = make_name prefix (!Lexer_cocci.line) in
- let name_res =
- if starts_with_name
- then
- let (_,tokens) = get_tokens [PC.TArob] in
- let check_name = function
- None -> Some (mknm())
- | Some nm ->
- (if List.mem nm reserved_names
- then failwith (Printf.sprintf "invalid name %s\n" nm));
- Some nm in
- match parse_one "rule name" parse_fn file tokens with
- Ast.CocciRulename (nm,a,b,c,d,e) ->
- Ast.CocciRulename (check_name nm,a,b,c,d,e)
- | Ast.GeneratedRulename (nm,a,b,c,d,e) ->
- Ast.GeneratedRulename (check_name nm,a,b,c,d,e)
- | Ast.ScriptRulename(s,deps) -> Ast.ScriptRulename(s,deps)
- else
- Ast.CocciRulename(Some(mknm()),Ast.NoDep,[],[],Ast.Undetermined,false) in
- Data.in_rule_name := false;
- name_res
-
-let parse_iso file =
- let table = Common.full_charpos_to_pos file in
- Common.with_open_infile file (fun channel ->
- let lexbuf = Lexing.from_channel channel in
- let get_tokens = tokens_all table file false lexbuf in
- let res =
- match get_tokens [PC.TArobArob;PC.TArob] with
- (true,start) ->
- let parse_start start =
- let rev = List.rev start in
- let (arob,_) = List.hd rev in
- (arob = PC.TArob,List.rev(List.tl rev)) in
- let (starts_with_name,start) = parse_start start in
- let rec loop starts_with_name start =
- (!Data.init_rule)();
- (* get metavariable declarations - have to be read before the
- rest *)
- let (rule_name,_,_,_,_,_) =
- match get_rule_name PC.iso_rule_name starts_with_name get_tokens
- file ("iso file "^file) with
- Ast.CocciRulename (Some n,a,b,c,d,e) -> (n,a,b,c,d,e)
- | _ -> failwith "Script rules cannot appear in isomorphism rules"
- in
- Ast0.rule_name := rule_name;
- Data.in_meta := true;
- let iso_metavars =
- match get_metavars PC.iso_meta_main table file lexbuf with
- (iso_metavars,[]) -> iso_metavars
- | _ -> failwith "unexpected inheritance in iso" in
- Data.in_meta := false;
- (* get the rule *)
- let (more,tokens) =
- get_tokens
- [PC.TIsoStatement;PC.TIsoExpression;PC.TIsoArgExpression;
- PC.TIsoTestExpression;
- PC.TIsoDeclaration;PC.TIsoType;PC.TIsoTopLevel] in
- let next_start = List.hd(List.rev tokens) in
- let dummy_info = ("",(-1,-1),(-1,-1)) in
- let tokens = drop_last [(PC.EOF,dummy_info)] tokens in
- let tokens = prepare_tokens (start@tokens) in
- (*
- print_tokens "iso tokens" tokens;
- *)
- let entry = parse_one "iso main" PC.iso_main file tokens in
- let entry = List.map (List.map Test_exps.process_anything) entry in
- if more
- then (* The code below allows a header like Statement list,
- which is more than one word. We don't have that any more,
- but the code is left here in case it is put back. *)
- match get_tokens [PC.TArobArob;PC.TArob] with
- (true,start) ->
- let (starts_with_name,start) = parse_start start in
- (iso_metavars,entry,rule_name) ::
- (loop starts_with_name (next_start::start))
- | _ -> failwith "isomorphism ends early"
- else [(iso_metavars,entry,rule_name)] in
- loop starts_with_name start
- | (false,_) -> [] in
- res)
-
-let parse_iso_files existing_isos iso_files extra_path =
- let get_names = List.map (function (_,_,nm) -> nm) in
- let old_names = get_names existing_isos in
- Data.in_iso := true;
- let (res,_) =
- List.fold_left
- (function (prev,names) ->
- function file ->
- Lexer_cocci.init ();
- let file =
- match file with
- Common.Left(fl) -> Filename.concat extra_path fl
- | Common.Right(fl) -> Filename.concat Config.path fl in
- let current = parse_iso file in
- let new_names = get_names current in
- if List.exists (function x -> List.mem x names) new_names
- then failwith (Printf.sprintf "repeated iso name found in %s" file);
- (current::prev,new_names @ names))
- ([],old_names) iso_files in
- Data.in_iso := false;
- existing_isos@(List.concat (List.rev res))
-
-let parse file =
- let table = Common.full_charpos_to_pos file in
- Common.with_open_infile file (fun channel ->
- let lexbuf = Lexing.from_channel channel in
- let get_tokens = tokens_all table file false lexbuf in
- Data.in_prolog := true;
- let initial_tokens = get_tokens [PC.TArobArob;PC.TArob] in
- Data.in_prolog := false;
- let res =
- match initial_tokens with
- (true,data) ->
- (match List.rev data with
- ((PC.TArobArob as x),_)::_ | ((PC.TArob as x),_)::_ ->
- let iso_files =
- parse_one "iso file names" PC.include_main file data in
-
- let parse_cocci_rule ruletype old_metas
- (rule_name, dependencies, iso, dropiso, exists, is_expression) =
- Ast0.rule_name := rule_name;
- Data.inheritable_positions :=
- rule_name :: !Data.inheritable_positions;
-
- (* get metavariable declarations *)
- Data.in_meta := true;
- let (metavars, inherited_metavars) =
- get_metavars PC.meta_main table file lexbuf in
- Data.in_meta := false;
- Hashtbl.add Data.all_metadecls rule_name metavars;
- Hashtbl.add Lexer_cocci.rule_names rule_name ();
- Hashtbl.add Lexer_cocci.all_metavariables rule_name
- (Hashtbl.fold
- (fun key v rest -> (key,v)::rest)
- Lexer_cocci.metavariables []);
-
- (* get transformation rules *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
- let (minus_tokens, plus_tokens) = split_token_stream tokens in
-
- let minus_tokens = consume_minus_positions minus_tokens in
- let minus_tokens = prepare_tokens minus_tokens in
- let plus_tokens = prepare_tokens plus_tokens in
-
- (*
- print_tokens "minus tokens" minus_tokens;
- print_tokens "plus tokens" plus_tokens;
- *)
-
- let plus_tokens =
- process_pragmas
- (fix (function x -> drop_double_dots (drop_empty_or x))
- (drop_when plus_tokens)) in
- (*
- print_tokens "plus tokens" plus_tokens;
- Printf.printf "before minus parse\n";
- *)
- let minus_res =
- if is_expression
- then parse_one "minus" PC.minus_exp_main file minus_tokens
- else parse_one "minus" PC.minus_main file minus_tokens in
- (*
- Unparse_ast0.unparse minus_res;
- Printf.printf "before plus parse\n";
- *)
- let plus_res =
- if !Flag.sgrep_mode2
- then (* not actually used for anything, except context_neg *)
- List.map
- (Iso_pattern.rebuild_mcode None).V0.rebuilder_top_level
- minus_res
- else
- if is_expression
- then parse_one "plus" PC.plus_exp_main file plus_tokens
- else parse_one "plus" PC.plus_main file plus_tokens in
- (*
- Printf.printf "after plus parse\n";
- *)
-
- (if not !Flag.sgrep_mode2 &&
- (any_modif minus_res or any_modif plus_res)
- then Data.inheritable_positions := []);
-
- Check_meta.check_meta rule_name old_metas inherited_metavars
- metavars minus_res plus_res;
-
- (more, Ast0.CocciRule ((minus_res, metavars,
- (iso, dropiso, dependencies, rule_name, exists)),
- (plus_res, metavars), ruletype), metavars, tokens) in
-
- let parse_script_rule language old_metas deps =
- let get_tokens = tokens_script_all table file false lexbuf in
-
- (* meta-variables *)
- Data.in_meta := true;
- let metavars =
- get_script_metavars PC.script_meta_main table file lexbuf in
- Data.in_meta := false;
-
- let exists_in old_metas (py,(r,m)) =
- let test (rr,mr) x =
- let (ro,vo) = Ast.get_meta_name x in
- ro = rr && vo = mr in
- List.exists (test (r,m)) old_metas in
-
- List.iter
- (function x ->
- let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
- if not (exists_in old_metas x) then
- failwith
- (Printf.sprintf
- "Script references unknown meta-variable: %s"
- (meta2c(snd x))))
- metavars;
-
- (* script code *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
- let data =
- match List.hd tokens with
- (PC.TScriptData(s),_) -> s
- | (PC.TArobArob,_) | (PC.TArob,_) -> ""
- | _ -> failwith "Malformed script rule" in
- (more,Ast0.ScriptRule(language, deps, metavars, data),[],tokens) in
-
- let parse_rule old_metas starts_with_name =
- let rulename =
- get_rule_name PC.rule_name starts_with_name get_tokens file
- "rule" in
- match rulename with
- Ast.CocciRulename (Some s, a, b, c, d, e) ->
- parse_cocci_rule Ast.Normal old_metas (s, a, b, c, d, e)
- | Ast.GeneratedRulename (Some s, a, b, c, d, e) ->
- Data.in_generating := true;
- let res =
- parse_cocci_rule Ast.Generated old_metas (s,a,b,c,d,e) in
- Data.in_generating := false;
- res
- | Ast.ScriptRulename (l,deps) -> parse_script_rule l old_metas deps
- | _ -> failwith "Malformed rule name"
- in
-
- let rec loop old_metas starts_with_name =
- (!Data.init_rule)();
-
- let gen_starts_with_name more tokens =
- more &&
- (match List.hd (List.rev tokens) with
- (PC.TArobArob,_) -> false
- | (PC.TArob,_) -> true
- | _ -> failwith "unexpected token")
- in
-
- let (more, rule, metavars, tokens) =
- parse_rule old_metas starts_with_name in
- if more then
- rule::
- (loop (metavars @ old_metas) (gen_starts_with_name more tokens))
- else [rule];
-
- in
-
- (iso_files, loop [] (x = PC.TArob))
- | _ -> failwith "unexpected code before the first rule\n")
- | (false,[(PC.TArobArob,_)]) | (false,[(PC.TArob,_)]) ->
- ([],([] : Ast0.parsed_rule list))
- | _ -> failwith "unexpected code before the first rule\n" in
- res)
-
-(* parse to ast0 and then convert to ast *)
-let process file isofile verbose =
- let extra_path = Filename.dirname file in
- Lexer_cocci.init();
- let (iso_files, rules) = parse file in
- let std_isos =
- match isofile with
- None -> []
- | Some iso_file -> parse_iso_files [] [Common.Left iso_file] "" in
- let global_isos = parse_iso_files std_isos iso_files extra_path in
- let rules = Unitary_ast0.do_unitary rules in
- let parsed =
- List.map
- (function
- Ast0.ScriptRule (a,b,c,d) -> [([],Ast.ScriptRule (a,b,c,d))]
- | Ast0.CocciRule
- ((minus, metavarsm,
- (iso, dropiso, dependencies, rule_name, exists)),
- (plus, metavars),ruletype) ->
- let chosen_isos =
- parse_iso_files global_isos
- (List.map (function x -> Common.Left x) iso)
- extra_path in
- let chosen_isos =
- (* check that dropped isos are actually available *)
- (try
- let iso_names =
- List.map (function (_,_,nm) -> nm) chosen_isos in
- let local_iso_names = reserved_names @ iso_names in
- let bad_dropped =
- List.find
- (function dropped ->
- not (List.mem dropped local_iso_names))
- dropiso in
- failwith
- ("invalid iso name " ^ bad_dropped ^ " in " ^ rule_name)
- with Not_found -> ());
- if List.mem "all" dropiso
- then
- if List.length dropiso = 1
- then []
- else failwith "disable all should only be by itself"
- else (* drop those isos *)
- List.filter
- (function (_,_,nm) -> not (List.mem nm dropiso))
- chosen_isos in
- List.iter Iso_compile.process chosen_isos;
- let dropped_isos =
- match reserved_names with
- "all"::others ->
- (match dropiso with
- ["all"] -> others
- | _ ->
- List.filter (function x -> List.mem x dropiso) others)
- | _ ->
- failwith
- "bad list of reserved names - all must be at start" in
- let minus = Test_exps.process minus in
- let minus = Compute_lines.compute_lines minus in
- let plus = Compute_lines.compute_lines plus in
- let is_exp =
- (* only relevant to Flag.make_hrule *)
- (* doesn't handle multiple minirules properly, but since
- we don't really handle them in lots of other ways, it
- doesn't seem very important *)
- match plus with
- [] -> [false]
- | p::_ ->
- [match Ast0.unwrap p with
- Ast0.CODE c ->
- (match List.map Ast0.unwrap (Ast0.undots c) with
- [Ast0.Exp e] -> true | _ -> false)
- | _ -> false] in
- let minus = Arity.minus_arity minus in
- let ((metavars,minus),function_prototypes) =
- Function_prototypes.process
- rule_name metavars dropped_isos minus plus ruletype in
- (* warning! context_neg side-effects its arguments *)
- let (m,p) = List.split (Context_neg.context_neg minus plus) in
- Type_infer.type_infer p;
- (if not !Flag.sgrep_mode2
- then Insert_plus.insert_plus m p (chosen_isos = []));
- Type_infer.type_infer minus;
- let (extra_meta, minus) =
- match (chosen_isos,ruletype) with
- (* separate case for [] because applying isos puts
- some restrictions on the -+ code *)
- ([],_) | (_,Ast.Generated) -> ([],minus)
- | _ -> Iso_pattern.apply_isos chosen_isos minus rule_name in
- let minus = Comm_assoc.comm_assoc minus rule_name dropiso in
- let minus =
- if !Flag.sgrep_mode2 then minus
- else Single_statement.single_statement minus in
- let minus = Simple_assignments.simple_assignments minus in
- let minus_ast =
- Ast0toast.ast0toast rule_name dependencies dropped_isos
- exists minus is_exp ruletype in
- match function_prototypes with
- None -> [(extra_meta @ metavars, minus_ast)]
- | Some mv_fp ->
- [(extra_meta @ metavars, minus_ast); mv_fp])
-(* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
- rules in
- let parsed = List.concat parsed in
- let disjd = Disjdistr.disj parsed in
-
- let (metavars,code,fvs,neg_pos,ua,pos) = Free_vars.free_vars disjd in
- if !Flag_parsing_cocci.show_SP
- then List.iter Pretty_print_cocci.unparse code;
-
- let grep_tokens =
- Common.profile_code "get_constants"
- (fun () -> Get_constants.get_constants code) in (* for grep *)
- let glimpse_tokens2 =
- Common.profile_code "get_glimpse_constants"
- (fun () -> Get_constants2.get_constants code neg_pos) in(* for glimpse *)
- (metavars,code,fvs,neg_pos,ua,pos,grep_tokens,glimpse_tokens2)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* splits the entire file into minus and plus fragments, and parses each
-separately (thus duplicating work for the parsing of the context elements) *)
-
-module D = Data
-module PC = Parser_cocci_menhir
-module V0 = Visitor_ast0
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-let pr = Printf.sprintf
-(*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*)
-let pr2 s = Printf.printf "%s\n" s
-
-(* for isomorphisms. all should be at the front!!! *)
-let reserved_names =
- ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"]
-
-(* ----------------------------------------------------------------------- *)
-(* Debugging... *)
-
-let line_type (d,_,_,_,_,_,_,_) = d
-
-let line_type2c tok =
- match line_type tok with
- D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ":-"
- | D.PLUS -> ":+"
- | D.CONTEXT | D.UNIQUE | D.OPT -> ""
-
-let token2c (tok,_) =
- match tok with
- PC.TIdentifier -> "identifier"
- | PC.TType -> "type"
- | PC.TParameter -> "parameter"
- | PC.TConstant -> "constant"
- | PC.TExpression -> "expression"
- | PC.TIdExpression -> "idexpression"
- | PC.TInitialiser -> "initialiser"
- | PC.TStatement -> "statement"
- | PC.TPosition -> "position"
- | PC.TPosAny -> "any"
- | PC.TFunction -> "function"
- | PC.TLocal -> "local"
- | PC.Tlist -> "list"
- | PC.TFresh -> "fresh"
- | PC.TPure -> "pure"
- | PC.TContext -> "context"
- | PC.TTypedef -> "typedef"
- | PC.TDeclarer -> "declarer"
- | PC.TIterator -> "iterator"
- | PC.TName -> "name"
- | PC.TRuleName str -> "rule_name-"^str
- | PC.TUsing -> "using"
- | PC.TPathIsoFile str -> "path_iso_file-"^str
- | PC.TDisable -> "disable"
- | PC.TExtends -> "extends"
- | PC.TDepends -> "depends"
- | PC.TOn -> "on"
- | PC.TEver -> "ever"
- | PC.TNever -> "never"
- | PC.TExists -> "exists"
- | PC.TForall -> "forall"
- | PC.TReverse -> "reverse"
- | PC.TError -> "error"
- | PC.TWords -> "words"
- | PC.TGenerated -> "generated"
-
- | PC.TNothing -> "nothing"
-
- | PC.Tchar(clt) -> "char"^(line_type2c clt)
- | PC.Tshort(clt) -> "short"^(line_type2c clt)
- | PC.Tint(clt) -> "int"^(line_type2c clt)
- | PC.Tdouble(clt) -> "double"^(line_type2c clt)
- | PC.Tfloat(clt) -> "float"^(line_type2c clt)
- | PC.Tlong(clt) -> "long"^(line_type2c clt)
- | PC.Tvoid(clt) -> "void"^(line_type2c clt)
- | PC.Tstruct(clt) -> "struct"^(line_type2c clt)
- | PC.Tunion(clt) -> "union"^(line_type2c clt)
- | PC.Tenum(clt) -> "enum"^(line_type2c clt)
- | PC.Tunsigned(clt) -> "unsigned"^(line_type2c clt)
- | PC.Tsigned(clt) -> "signed"^(line_type2c clt)
- | PC.Tstatic(clt) -> "static"^(line_type2c clt)
- | PC.Tinline(clt) -> "inline"^(line_type2c clt)
- | PC.Ttypedef(clt) -> "typedef"^(line_type2c clt)
- | PC.Tattr(s,clt) -> s^(line_type2c clt)
- | PC.Tauto(clt) -> "auto"^(line_type2c clt)
- | PC.Tregister(clt) -> "register"^(line_type2c clt)
- | PC.Textern(clt) -> "extern"^(line_type2c clt)
- | PC.Tconst(clt) -> "const"^(line_type2c clt)
- | PC.Tvolatile(clt) -> "volatile"^(line_type2c clt)
-
- | PC.TPragma(s) -> s
- | PC.TIncludeL(s,clt) -> (pr "#include \"%s\"" s)^(line_type2c clt)
- | PC.TIncludeNL(s,clt) -> (pr "#include <%s>" s)^(line_type2c clt)
- | PC.TDefine(clt,_) -> "#define"^(line_type2c clt)
- | PC.TDefineParam(clt,_,_) -> "#define_param"^(line_type2c clt)
- | PC.TMinusFile(s,clt) -> (pr "--- %s" s)^(line_type2c clt)
- | PC.TPlusFile(s,clt) -> (pr "+++ %s" s)^(line_type2c clt)
-
- | PC.TInc(clt) -> "++"^(line_type2c clt)
- | PC.TDec(clt) -> "--"^(line_type2c clt)
-
- | PC.TIf(clt) -> "if"^(line_type2c clt)
- | PC.TElse(clt) -> "else"^(line_type2c clt)
- | PC.TWhile(clt) -> "while"^(line_type2c clt)
- | PC.TFor(clt) -> "for"^(line_type2c clt)
- | PC.TDo(clt) -> "do"^(line_type2c clt)
- | PC.TSwitch(clt) -> "switch"^(line_type2c clt)
- | PC.TCase(clt) -> "case"^(line_type2c clt)
- | PC.TDefault(clt) -> "default"^(line_type2c clt)
- | PC.TReturn(clt) -> "return"^(line_type2c clt)
- | PC.TBreak(clt) -> "break"^(line_type2c clt)
- | PC.TContinue(clt) -> "continue"^(line_type2c clt)
- | PC.TGoto(clt) -> "goto"^(line_type2c clt)
- | PC.TIdent(s,clt) -> (pr "ident-%s" s)^(line_type2c clt)
- | PC.TTypeId(s,clt) -> (pr "typename-%s" s)^(line_type2c clt)
- | PC.TDeclarerId(s,clt) -> (pr "declarername-%s" s)^(line_type2c clt)
- | PC.TIteratorId(s,clt) -> (pr "iteratorname-%s" s)^(line_type2c clt)
- | PC.TMetaDeclarer(_,_,_,clt) -> "declmeta"^(line_type2c clt)
- | PC.TMetaIterator(_,_,_,clt) -> "itermeta"^(line_type2c clt)
-
- | PC.TSizeof(clt) -> "sizeof"^(line_type2c clt)
-
- | PC.TString(x,clt) -> x^(line_type2c clt)
- | PC.TChar(x,clt) -> x^(line_type2c clt)
- | PC.TFloat(x,clt) -> x^(line_type2c clt)
- | PC.TInt(x,clt) -> x^(line_type2c clt)
-
- | PC.TOrLog(clt) -> "||"^(line_type2c clt)
- | PC.TAndLog(clt) -> "&&"^(line_type2c clt)
- | PC.TOr(clt) -> "|"^(line_type2c clt)
- | PC.TXor(clt) -> "^"^(line_type2c clt)
- | PC.TAnd (clt) -> "&"^(line_type2c clt)
- | PC.TEqEq(clt) -> "=="^(line_type2c clt)
- | PC.TNotEq(clt) -> "!="^(line_type2c clt)
- | PC.TLogOp(op,clt) ->
- (match op with
- Ast.Inf -> "<"
- | Ast.InfEq -> "<="
- | Ast.Sup -> ">"
- | Ast.SupEq -> ">="
- | _ -> failwith "not possible")
- ^(line_type2c clt)
- | PC.TShOp(op,clt) ->
- (match op with
- Ast.DecLeft -> "<<"
- | Ast.DecRight -> ">>"
- | _ -> failwith "not possible")
- ^(line_type2c clt)
- | PC.TPlus(clt) -> "+"^(line_type2c clt)
- | PC.TMinus(clt) -> "-"^(line_type2c clt)
- | PC.TMul(clt) -> "*"^(line_type2c clt)
- | PC.TDmOp(op,clt) ->
- (match op with
- Ast.Div -> "/"
- | Ast.Mod -> "%"
- | _ -> failwith "not possible")
- ^(line_type2c clt)
- | PC.TTilde (clt) -> "~"^(line_type2c clt)
-
- | PC.TMetaParam(_,_,clt) -> "parammeta"^(line_type2c clt)
- | PC.TMetaParamList(_,_,_,clt) -> "paramlistmeta"^(line_type2c clt)
- | PC.TMetaConst(_,_,_,_,clt) -> "constmeta"^(line_type2c clt)
- | PC.TMetaErr(_,_,_,clt) -> "errmeta"^(line_type2c clt)
- | PC.TMetaExp(_,_,_,_,clt) -> "expmeta"^(line_type2c clt)
- | PC.TMetaIdExp(_,_,_,_,clt) -> "idexpmeta"^(line_type2c clt)
- | PC.TMetaLocalIdExp(_,_,_,_,clt) -> "localidexpmeta"^(line_type2c clt)
- | PC.TMetaExpList(_,_,_,clt) -> "explistmeta"^(line_type2c clt)
- | PC.TMetaId(_,_,_,clt) -> "idmeta"^(line_type2c clt)
- | PC.TMetaType(_,_,clt) -> "typemeta"^(line_type2c clt)
- | PC.TMetaInit(_,_,clt) -> "initmeta"^(line_type2c clt)
- | PC.TMetaStm(_,_,clt) -> "stmmeta"^(line_type2c clt)
- | PC.TMetaStmList(_,_,clt) -> "stmlistmeta"^(line_type2c clt)
- | PC.TMetaFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt)
- | PC.TMetaLocalFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt)
- | PC.TMetaPos(_,_,_,clt) -> "posmeta"
- | PC.TMPtVirg -> ";"
- | PC.TArobArob -> "@@"
- | PC.TArob -> "@"
- | PC.TPArob -> "P@"
- | PC.TScript -> "script"
-
- | PC.TWhen(clt) -> "WHEN"^(line_type2c clt)
- | PC.TWhenTrue(clt) -> "WHEN TRUE"^(line_type2c clt)
- | PC.TWhenFalse(clt) -> "WHEN FALSE"^(line_type2c clt)
- | PC.TAny(clt) -> "ANY"^(line_type2c clt)
- | PC.TStrict(clt) -> "STRICT"^(line_type2c clt)
- | PC.TEllipsis(clt) -> "..."^(line_type2c clt)
-(*
- | PC.TCircles(clt) -> "ooo"^(line_type2c clt)
- | PC.TStars(clt) -> "***"^(line_type2c clt)
-*)
-
- | PC.TOEllipsis(clt) -> "<..."^(line_type2c clt)
- | PC.TCEllipsis(clt) -> "...>"^(line_type2c clt)
- | PC.TPOEllipsis(clt) -> "<+..."^(line_type2c clt)
- | PC.TPCEllipsis(clt) -> "...+>"^(line_type2c clt)
-(*
- | PC.TOCircles(clt) -> "<ooo"^(line_type2c clt)
- | PC.TCCircles(clt) -> "ooo>"^(line_type2c clt)
- | PC.TOStars(clt) -> "<***"^(line_type2c clt)
- | PC.TCStars(clt) -> "***>"^(line_type2c clt)
-*)
- | PC.TBang0 -> "!"
- | PC.TPlus0 -> "+"
- | PC.TWhy0 -> "?"
-
- | PC.TWhy(clt) -> "?"^(line_type2c clt)
- | PC.TDotDot(clt) -> ":"^(line_type2c clt)
- | PC.TBang(clt) -> "!"^(line_type2c clt)
- | PC.TOPar(clt) -> "("^(line_type2c clt)
- | PC.TOPar0(clt) -> "("^(line_type2c clt)
- | PC.TMid0(clt) -> "|"^(line_type2c clt)
- | PC.TCPar(clt) -> ")"^(line_type2c clt)
- | PC.TCPar0(clt) -> ")"^(line_type2c clt)
-
- | PC.TOBrace(clt) -> "{"^(line_type2c clt)
- | PC.TCBrace(clt) -> "}"^(line_type2c clt)
- | PC.TOCro(clt) -> "["^(line_type2c clt)
- | PC.TCCro(clt) -> "]"^(line_type2c clt)
- | PC.TOInit(clt) -> "{"^(line_type2c clt)
-
- | PC.TPtrOp(clt) -> "->"^(line_type2c clt)
-
- | PC.TEq(clt) -> "="^(line_type2c clt)
- | PC.TAssign(_,clt) -> "=op"^(line_type2c clt)
- | PC.TDot(clt) -> "."^(line_type2c clt)
- | PC.TComma(clt) -> ","^(line_type2c clt)
- | PC.TPtVirg(clt) -> ";"^(line_type2c clt)
-
- | PC.EOF -> "eof"
- | PC.TLineEnd(clt) -> "line end"
- | PC.TInvalid -> "invalid"
- | PC.TFunDecl(clt) -> "fundecl"
-
- | PC.TIso -> "<=>"
- | PC.TRightIso -> "=>"
- | PC.TIsoTopLevel -> "TopLevel"
- | PC.TIsoExpression -> "Expression"
- | PC.TIsoArgExpression -> "ArgExpression"
- | PC.TIsoTestExpression -> "TestExpression"
- | PC.TIsoStatement -> "Statement"
- | PC.TIsoDeclaration -> "Declaration"
- | PC.TIsoType -> "Type"
- | PC.TScriptData s -> s
-
-let print_tokens s tokens =
- Printf.printf "%s\n" s;
- List.iter (function x -> Printf.printf "%s " (token2c x)) tokens;
- Printf.printf "\n\n";
- flush stdout
-
-type plus = PLUS | NOTPLUS | SKIP
-
-let plus_attachable (tok,_) =
- match tok with
- PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt)
- | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt)
- | PC.Tauto(clt) | PC.Tregister(clt)
- | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt)
-
- | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_)
- | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt)
-
- | PC.TInc(clt) | PC.TDec(clt)
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
- | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
-
- | PC.TSizeof(clt)
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt)
-
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt)
- | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
- | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt)
- | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaStm(_,_,clt)
- | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
- | PC.TMetaLocalFunc(_,_,_,clt)
-
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
- | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
- (* | PC.TCircles(clt) | PC.TStars(clt) *)
-
- | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
- | PC.TCPar(clt)
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
- | PC.TOInit(clt)
-
- | PC.TPtrOp(clt)
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) ->
- if line_type clt = D.PLUS then PLUS else NOTPLUS
-
- | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
- | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
- | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt)
- | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS
- | PC.TMetaPos(nm,_,_,_) -> NOTPLUS
-
- | _ -> SKIP
-
-let get_clt (tok,_) =
- match tok with
- PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt)
- | PC.Tinline(clt) | PC.Tattr(_,clt) | PC.Tauto(clt) | PC.Tregister(clt)
- | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt)
-
- | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_)
- | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt)
-
- | PC.TInc(clt) | PC.TDec(clt)
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
- | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
-
- | PC.TSizeof(clt)
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt)
-
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt)
- | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
- | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt)
- | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaStm(_,_,clt)
- | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
- | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt)
-
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) |
- PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
- (* | PC.TCircles(clt) | PC.TStars(clt) *)
-
- | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
- | PC.TCPar(clt)
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
- | PC.TOInit(clt)
-
- | PC.TPtrOp(clt)
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt)
-
- | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
- | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
- | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt)
- | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt
-
- | _ -> failwith "no clt"
-
-let update_clt (tok,x) clt =
- match tok with
- PC.Tchar(_) -> (PC.Tchar(clt),x)
- | PC.Tshort(_) -> (PC.Tshort(clt),x)
- | PC.Tint(_) -> (PC.Tint(clt),x)
- | PC.Tdouble(_) -> (PC.Tdouble(clt),x)
- | PC.Tfloat(_) -> (PC.Tfloat(clt),x)
- | PC.Tlong(_) -> (PC.Tlong(clt),x)
- | PC.Tvoid(_) -> (PC.Tvoid(clt),x)
- | PC.Tstruct(_) -> (PC.Tstruct(clt),x)
- | PC.Tunion(_) -> (PC.Tunion(clt),x)
- | PC.Tenum(_) -> (PC.Tenum(clt),x)
- | PC.Tunsigned(_) -> (PC.Tunsigned(clt),x)
- | PC.Tsigned(_) -> (PC.Tsigned(clt),x)
- | PC.Tstatic(_) -> (PC.Tstatic(clt),x)
- | PC.Tinline(_) -> (PC.Tinline(clt),x)
- | PC.Ttypedef(_) -> (PC.Ttypedef(clt),x)
- | PC.Tattr(s,_) -> (PC.Tattr(s,clt),x)
- | PC.Tauto(_) -> (PC.Tauto(clt),x)
- | PC.Tregister(_) -> (PC.Tregister(clt),x)
- | PC.Textern(_) -> (PC.Textern(clt),x)
- | PC.Tconst(_) -> (PC.Tconst(clt),x)
- | PC.Tvolatile(_) -> (PC.Tvolatile(clt),x)
-
- | PC.TIncludeL(s,_) -> (PC.TIncludeL(s,clt),x)
- | PC.TIncludeNL(s,_) -> (PC.TIncludeNL(s,clt),x)
- | PC.TDefine(_,a) -> (PC.TDefine(clt,a),x)
- | PC.TDefineParam(_,a,b) -> (PC.TDefineParam(clt,a,b),x)
- | PC.TMinusFile(s,_) -> (PC.TMinusFile(s,clt),x)
- | PC.TPlusFile(s,_) -> (PC.TPlusFile(s,clt),x)
-
- | PC.TInc(_) -> (PC.TInc(clt),x)
- | PC.TDec(_) -> (PC.TDec(clt),x)
-
- | PC.TIf(_) -> (PC.TIf(clt),x)
- | PC.TElse(_) -> (PC.TElse(clt),x)
- | PC.TWhile(_) -> (PC.TWhile(clt),x)
- | PC.TFor(_) -> (PC.TFor(clt),x)
- | PC.TDo(_) -> (PC.TDo(clt),x)
- | PC.TSwitch(_) -> (PC.TSwitch(clt),x)
- | PC.TCase(_) -> (PC.TCase(clt),x)
- | PC.TDefault(_) -> (PC.TDefault(clt),x)
- | PC.TReturn(_) -> (PC.TReturn(clt),x)
- | PC.TBreak(_) -> (PC.TBreak(clt),x)
- | PC.TContinue(_) -> (PC.TContinue(clt),x)
- | PC.TGoto(_) -> (PC.TGoto(clt),x)
- | PC.TIdent(s,_) -> (PC.TIdent(s,clt),x)
- | PC.TTypeId(s,_) -> (PC.TTypeId(s,clt),x)
- | PC.TDeclarerId(s,_) -> (PC.TDeclarerId(s,clt),x)
- | PC.TIteratorId(s,_) -> (PC.TIteratorId(s,clt),x)
-
- | PC.TSizeof(_) -> (PC.TSizeof(clt),x)
-
- | PC.TString(s,_) -> (PC.TString(s,clt),x)
- | PC.TChar(s,_) -> (PC.TChar(s,clt),x)
- | PC.TFloat(s,_) -> (PC.TFloat(s,clt),x)
- | PC.TInt(s,_) -> (PC.TInt(s,clt),x)
-
- | PC.TOrLog(_) -> (PC.TOrLog(clt),x)
- | PC.TAndLog(_) -> (PC.TAndLog(clt),x)
- | PC.TOr(_) -> (PC.TOr(clt),x)
- | PC.TXor(_) -> (PC.TXor(clt),x)
- | PC.TAnd (_) -> (PC.TAnd (clt),x)
- | PC.TEqEq(_) -> (PC.TEqEq(clt),x)
- | PC.TNotEq(_) -> (PC.TNotEq(clt),x)
- | PC.TLogOp(op,_) -> (PC.TLogOp(op,clt),x)
- | PC.TShOp(op,_) -> (PC.TShOp(op,clt),x)
- | PC.TPlus(_) -> (PC.TPlus(clt),x)
- | PC.TMinus(_) -> (PC.TMinus(clt),x)
- | PC.TMul(_) -> (PC.TMul(clt),x)
- | PC.TDmOp(op,_) -> (PC.TDmOp(op,clt),x)
- | PC.TTilde (_) -> (PC.TTilde (clt),x)
-
- | PC.TMetaParam(a,b,_) -> (PC.TMetaParam(a,b,clt),x)
- | PC.TMetaParamList(a,b,c,_) -> (PC.TMetaParamList(a,b,c,clt),x)
- | PC.TMetaConst(a,b,c,d,_) -> (PC.TMetaConst(a,b,c,d,clt),x)
- | PC.TMetaErr(a,b,c,_) -> (PC.TMetaErr(a,b,c,clt),x)
- | PC.TMetaExp(a,b,c,d,_) -> (PC.TMetaExp(a,b,c,d,clt),x)
- | PC.TMetaIdExp(a,b,c,d,_) -> (PC.TMetaIdExp(a,b,c,d,clt),x)
- | PC.TMetaLocalIdExp(a,b,c,d,_) -> (PC.TMetaLocalIdExp(a,b,c,d,clt),x)
- | PC.TMetaExpList(a,b,c,_) -> (PC.TMetaExpList(a,b,c,clt),x)
- | PC.TMetaId(a,b,c,_) -> (PC.TMetaId(a,b,c,clt),x)
- | PC.TMetaType(a,b,_) -> (PC.TMetaType(a,b,clt),x)
- | PC.TMetaInit(a,b,_) -> (PC.TMetaInit(a,b,clt),x)
- | PC.TMetaStm(a,b,_) -> (PC.TMetaStm(a,b,clt),x)
- | PC.TMetaStmList(a,b,_) -> (PC.TMetaStmList(a,b,clt),x)
- | PC.TMetaFunc(a,b,c,_) -> (PC.TMetaFunc(a,b,c,clt),x)
- | PC.TMetaLocalFunc(a,b,c,_) -> (PC.TMetaLocalFunc(a,b,c,clt),x)
-
- | PC.TWhen(_) -> (PC.TWhen(clt),x)
- | PC.TWhenTrue(_) -> (PC.TWhenTrue(clt),x)
- | PC.TWhenFalse(_) -> (PC.TWhenFalse(clt),x)
- | PC.TAny(_) -> (PC.TAny(clt),x)
- | PC.TStrict(_) -> (PC.TStrict(clt),x)
- | PC.TEllipsis(_) -> (PC.TEllipsis(clt),x)
-(*
- | PC.TCircles(_) -> (PC.TCircles(clt),x)
- | PC.TStars(_) -> (PC.TStars(clt),x)
-*)
-
- | PC.TOEllipsis(_) -> (PC.TOEllipsis(clt),x)
- | PC.TCEllipsis(_) -> (PC.TCEllipsis(clt),x)
- | PC.TPOEllipsis(_) -> (PC.TPOEllipsis(clt),x)
- | PC.TPCEllipsis(_) -> (PC.TPCEllipsis(clt),x)
-(*
- | PC.TOCircles(_) -> (PC.TOCircles(clt),x)
- | PC.TCCircles(_) -> (PC.TCCircles(clt),x)
- | PC.TOStars(_) -> (PC.TOStars(clt),x)
- | PC.TCStars(_) -> (PC.TCStars(clt),x)
-*)
-
- | PC.TWhy(_) -> (PC.TWhy(clt),x)
- | PC.TDotDot(_) -> (PC.TDotDot(clt),x)
- | PC.TBang(_) -> (PC.TBang(clt),x)
- | PC.TOPar(_) -> (PC.TOPar(clt),x)
- | PC.TOPar0(_) -> (PC.TOPar0(clt),x)
- | PC.TMid0(_) -> (PC.TMid0(clt),x)
- | PC.TCPar(_) -> (PC.TCPar(clt),x)
- | PC.TCPar0(_) -> (PC.TCPar0(clt),x)
-
- | PC.TOBrace(_) -> (PC.TOBrace(clt),x)
- | PC.TCBrace(_) -> (PC.TCBrace(clt),x)
- | PC.TOCro(_) -> (PC.TOCro(clt),x)
- | PC.TCCro(_) -> (PC.TCCro(clt),x)
- | PC.TOInit(_) -> (PC.TOInit(clt),x)
-
- | PC.TPtrOp(_) -> (PC.TPtrOp(clt),x)
-
- | PC.TEq(_) -> (PC.TEq(clt),x)
- | PC.TAssign(s,_) -> (PC.TAssign(s,clt),x)
- | PC.TDot(_) -> (PC.TDot(clt),x)
- | PC.TComma(_) -> (PC.TComma(clt),x)
- | PC.TPtVirg(_) -> (PC.TPtVirg(clt),x)
-
- | PC.TLineEnd(_) -> (PC.TLineEnd(clt),x)
- | PC.TFunDecl(_) -> (PC.TFunDecl(clt),x)
-
- | _ -> failwith "no clt"
-
-
-(* ----------------------------------------------------------------------- *)
-
-let make_name prefix ln = Printf.sprintf "%s starting on line %d" prefix ln
-
-(* ----------------------------------------------------------------------- *)
-(* Read tokens *)
-
-let wrap_lexbuf_info lexbuf =
- (Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf)
-
-let tokens_all_full token table file get_ats lexbuf end_markers :
- (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
- try
- let rec aux () =
- let result = token lexbuf in
- let info = (Lexing.lexeme lexbuf,
- (table.(Lexing.lexeme_start lexbuf)),
- (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) in
- if result = PC.EOF
- then
- if get_ats
- then failwith "unexpected end of file in a metavariable declaration"
- else (false,[(result,info)])
- else if List.mem result end_markers
- then (true,[(result,info)])
- else
- let (more,rest) = aux() in
- (more,(result, info)::rest)
- in aux ()
- with
- e -> pr2 (Common.error_message file (wrap_lexbuf_info lexbuf) ); raise e
-
-let tokens_all table file get_ats lexbuf end_markers :
- (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
- tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
-
-let tokens_script_all table file get_ats lexbuf end_markers :
- (bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
- tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers
-
-(* ----------------------------------------------------------------------- *)
-(* Split tokens into minus and plus fragments *)
-
-let split t clt =
- let (d,_,_,_,_,_,_,_) = clt in
- match d with
- D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ([t],[])
- | D.PLUS -> ([],[t])
- | D.CONTEXT | D.UNIQUE | D.OPT -> ([t],[t])
-
-let split_token ((tok,_) as t) =
- match tok with
- PC.TIdentifier | PC.TConstant | PC.TExpression | PC.TIdExpression
- | PC.TStatement | PC.TPosition | PC.TPosAny | PC.TInitialiser
- | PC.TFunction | PC.TTypedef | PC.TDeclarer | PC.TIterator | PC.TName
- | PC.TType | PC.TParameter | PC.TLocal | PC.Tlist | PC.TFresh | PC.TPure
- | PC.TContext | PC.TRuleName(_) | PC.TUsing | PC.TDisable | PC.TExtends
- | PC.TPathIsoFile(_)
- | PC.TDepends | PC.TOn | PC.TEver | PC.TNever | PC.TExists | PC.TForall
- | PC.TReverse
- | PC.TError | PC.TWords | PC.TGenerated | PC.TNothing -> ([t],[t])
-
- | PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt)
- | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt)
- | PC.Tconst(clt) | PC.Tvolatile(clt) -> split t clt
-
- | PC.TPragma(s) -> ([],[t]) (* only allowed in + *)
- | PC.TPlusFile(s,clt) | PC.TMinusFile(s,clt)
- | PC.TIncludeL(s,clt) | PC.TIncludeNL(s,clt) ->
- split t clt
- | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_) -> split t clt
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt)
- | PC.TSizeof(clt)
- | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
- | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
- | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt)
- | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaErr(_,_,_,clt)
- | PC.TMetaFunc(_,_,_,clt) | PC.TMetaLocalFunc(_,_,_,clt)
- | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt) -> split t clt
- | PC.TMPtVirg | PC.TArob | PC.TArobArob | PC.TScript -> ([t],[t])
- | PC.TPArob | PC.TMetaPos(_,_,_,_) -> ([t],[])
-
- | PC.TFunDecl(clt)
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
- | PC.TAny(clt) | PC.TStrict(clt) | PC.TLineEnd(clt)
- | PC.TEllipsis(clt) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt
-
- | PC.TOEllipsis(_) | PC.TCEllipsis(_) (* clt must be context *)
- | PC.TPOEllipsis(_) | PC.TPCEllipsis(_) (* clt must be context *)
-(*
- | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *)
- | PC.TOStars(_) | PC.TCStars(_) (* clt must be context *)
-*)
- | PC.TBang0 | PC.TPlus0 | PC.TWhy0 ->
- ([t],[t])
-
- | PC.TWhy(clt) | PC.TDotDot(clt)
- | PC.TBang(clt) | PC.TOPar(clt) | PC.TOPar0(clt)
- | PC.TMid0(clt) | PC.TCPar(clt) | PC.TCPar0(clt) -> split t clt
-
- | PC.TInc(clt) | PC.TDec(clt) -> split t clt
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) ->
- split t clt
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt) -> split t clt
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOInit(clt) -> split t clt
- | PC.TOCro(clt) | PC.TCCro(clt) -> split t clt
-
- | PC.TPtrOp(clt) -> split t clt
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) -> split t clt
-
- | PC.EOF | PC.TInvalid -> ([t],[t])
-
- | PC.TIso | PC.TRightIso
- | PC.TIsoExpression | PC.TIsoStatement | PC.TIsoDeclaration | PC.TIsoType
- | PC.TIsoTopLevel | PC.TIsoArgExpression | PC.TIsoTestExpression ->
- failwith "unexpected tokens"
- | PC.TScriptData s -> ([t],[t])
-
-let split_token_stream tokens =
- let rec loop = function
- [] -> ([],[])
- | token::tokens ->
- let (minus,plus) = split_token token in
- let (minus_stream,plus_stream) = loop tokens in
- (minus@minus_stream,plus@plus_stream) in
- loop tokens
-
-(* ----------------------------------------------------------------------- *)
-(* Find function names *)
-(* This addresses a shift-reduce problem in the parser, allowing us to
-distinguish a function declaration from a function call even if the latter
-has no return type. Undoubtedly, this is not very nice, but it doesn't
-seem very convenient to refactor the grammar to get around the problem. *)
-
-let rec find_function_names = function
- [] -> []
- | ((PC.TIdent(_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaId(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaFunc(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaLocalFunc(_,_,_,clt),info) as t1)::((PC.TOPar(_),_) as t2)::rest
- ->
- let rec skip level = function
- [] -> ([],false,[])
- | ((PC.TCPar(_),_) as t)::rest ->
- let level = level - 1 in
- if level = 0
- then ([t],true,rest)
- else let (pre,found,post) = skip level rest in (t::pre,found,post)
- | ((PC.TOPar(_),_) as t)::rest ->
- let level = level + 1 in
- let (pre,found,post) = skip level rest in (t::pre,found,post)
- | ((PC.TArobArob,_) as t)::rest
- | ((PC.TArob,_) as t)::rest
- | ((PC.EOF,_) as t)::rest -> ([t],false,rest)
- | t::rest ->
- let (pre,found,post) = skip level rest in (t::pre,found,post) in
- let (pre,found,post) = skip 1 rest in
- (match (found,post) with
- (true,((PC.TOBrace(_),_) as t3)::rest) ->
- (PC.TFunDecl(clt),info) :: t1 :: t2 :: pre @
- t3 :: (find_function_names rest)
- | _ -> t1 :: t2 :: pre @ find_function_names post)
- | t :: rest -> t :: find_function_names rest
-
-(* ----------------------------------------------------------------------- *)
-(* an attribute is an identifier that preceeds another identifier and
- begins with __ *)
-
-let rec detect_attr l =
- let is_id = function
- (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
- | (PC.TMetaLocalFunc(_,_,_,_),_) -> true
- | _ -> false in
- let rec loop = function
- [] -> []
- | [x] -> [x]
- | ((PC.TIdent(nm,clt),info) as t1)::id::rest when is_id id ->
- if String.length nm > 2 && String.sub nm 0 2 = "__"
- then (PC.Tattr(nm,clt),info)::(loop (id::rest))
- else t1::(loop (id::rest))
- | x::xs -> x::(loop xs) in
- loop l
-
-(* ----------------------------------------------------------------------- *)
-(* Look for variable declarations where the name is a typedef name.
-We assume that C code does not contain a multiplication as a top-level
-statement. *)
-
-(* bug: once a type, always a type, even if the same name is later intended
- to be used as a real identifier *)
-let detect_types in_meta_decls l =
- let is_delim infn = function
- (PC.TOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
- | (PC.TPOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *)
- | (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *)
- | (PC.TPtVirg(_),_) | (PC.TOBrace(_),_) | (PC.TOInit(_),_)
- | (PC.TCBrace(_),_)
- | (PC.TPure,_) | (PC.TContext,_)
- | (PC.Tstatic(_),_) | (PC.Textern(_),_)
- | (PC.Tinline(_),_) | (PC.Ttypedef(_),_) | (PC.Tattr(_),_) -> true
- | (PC.TComma(_),_) when infn > 0 or in_meta_decls -> true
- | (PC.TDotDot(_),_) when in_meta_decls -> true
- | _ -> false in
- let is_choices_delim = function
- (PC.TOBrace(_),_) | (PC.TComma(_),_) -> true | _ -> false in
- let is_id = function
- (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
- | (PC.TMetaLocalFunc(_,_,_,_),_) -> true
- | (PC.TMetaParam(_,_,_),_)
- | (PC.TMetaParamList(_,_,_,_),_)
- | (PC.TMetaConst(_,_,_,_,_),_)
- | (PC.TMetaErr(_,_,_,_),_)
- | (PC.TMetaExp(_,_,_,_,_),_)
- | (PC.TMetaIdExp(_,_,_,_,_),_)
- | (PC.TMetaLocalIdExp(_,_,_,_,_),_)
- | (PC.TMetaExpList(_,_,_,_),_)
- | (PC.TMetaType(_,_,_),_)
- | (PC.TMetaInit(_,_,_),_)
- | (PC.TMetaStm(_,_,_),_)
- | (PC.TMetaStmList(_,_,_),_)
- | (PC.TMetaPos(_,_,_,_),_) -> in_meta_decls
- | _ -> false in
- let redo_id ident clt v =
- !Data.add_type_name ident;
- (PC.TTypeId(ident,clt),v) in
- let rec loop start infn type_names = function
- (* infn: 0 means not in a function header
- > 0 means in a function header, after infn - 1 unmatched open parens*)
- [] -> []
- | ((PC.TOBrace(clt),v)::_) as all when in_meta_decls ->
- collect_choices type_names all (* never a function header *)
- | delim::(PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest
- when is_delim infn delim ->
- let newid = redo_id ident clt v in
- delim::newid::x::(loop false infn (ident::type_names) rest)
- | delim::(PC.TIdent(ident,clt),v)::id::rest
- when is_delim infn delim && is_id id ->
- let newid = redo_id ident clt v in
- delim::newid::id::(loop false infn (ident::type_names) rest)
- | ((PC.TFunDecl(_),_) as fn)::rest ->
- fn::(loop false 1 type_names rest)
- | ((PC.TOPar(_),_) as lp)::rest when infn > 0 ->
- lp::(loop false (infn + 1) type_names rest)
- | ((PC.TCPar(_),_) as rp)::rest when infn > 0 ->
- if infn - 1 = 1
- then rp::(loop false 0 type_names rest) (* 0 means not in fn header *)
- else rp::(loop false (infn - 1) type_names rest)
- | (PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest when start ->
- let newid = redo_id ident clt v in
- newid::x::(loop false infn (ident::type_names) rest)
- | (PC.TIdent(ident,clt),v)::id::rest when start && is_id id ->
- let newid = redo_id ident clt v in
- newid::id::(loop false infn (ident::type_names) rest)
- | (PC.TIdent(ident,clt),v)::rest when List.mem ident type_names ->
- (PC.TTypeId(ident,clt),v)::(loop false infn type_names rest)
- | ((PC.TIdent(ident,clt),v) as x)::rest ->
- x::(loop false infn type_names rest)
- | x::rest -> x::(loop false infn type_names rest)
- and collect_choices type_names = function
- [] -> [] (* should happen, but let the parser detect that *)
- | (PC.TCBrace(clt),v)::rest ->
- (PC.TCBrace(clt),v)::(loop false 0 type_names rest)
- | delim::(PC.TIdent(ident,clt),v)::rest
- when is_choices_delim delim ->
- let newid = redo_id ident clt v in
- delim::newid::(collect_choices (ident::type_names) rest)
- | x::rest -> x::(collect_choices type_names rest) in
- loop true 0 [] l
-
-
-(* ----------------------------------------------------------------------- *)
-(* Insert TLineEnd tokens at the end of a line that contains a WHEN.
- WHEN is restricted to a single line, to avoid ambiguity in eg:
- ... WHEN != x
- +3 *)
-
-let token2line (tok,_) =
- match tok with
- PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt)
- | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt)
- | PC.Tunion(clt) | PC.Tenum(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt)
- | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt)
- | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt) | PC.Tconst(clt)
- | PC.Tvolatile(clt)
-
- | PC.TInc(clt) | PC.TDec(clt)
-
- | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
- | PC.TSwitch (clt) | PC.TCase (clt) | PC.TDefault (clt) | PC.TSizeof (clt)
- | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
- | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
- | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt)
-
- | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
-
- | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
- | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt)
- | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt)
- | PC.TDmOp(_,clt) | PC.TTilde (clt)
-
- | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
- | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
- | PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt)
- | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
- | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt)
-
- | PC.TFunDecl(clt)
- | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
- | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
- (* | PC.TCircles(clt) | PC.TStars(clt) *)
-
- | PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
- | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (*| PC.TOCircles(clt)
- | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *)
-
- | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt)
- | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar(clt)
- | PC.TCPar0(clt)
-
- | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt)
- | PC.TOInit(clt)
-
- | PC.TPtrOp(clt)
-
- | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_)
- | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt)
-
- | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) ->
- let (_,line,_,_,_,_,_,_) = clt in Some line
-
- | _ -> None
-
-let rec insert_line_end = function
- [] -> []
- | (((PC.TWhen(clt),q) as x)::xs) ->
- x::(find_line_end true (token2line x) clt q xs)
- | (((PC.TDefine(clt,_),q) as x)::xs)
- | (((PC.TDefineParam(clt,_,_),q) as x)::xs) ->
- x::(find_line_end false (token2line x) clt q xs)
- | x::xs -> x::(insert_line_end xs)
-
-and find_line_end inwhen line clt q = function
- (* don't know what 2nd component should be so just use the info of
- the When. Also inherit - of when, if any *)
- [] -> [(PC.TLineEnd(clt),q)]
- | ((PC.TIdent("strict",clt),a) as x)::xs when token2line x = line ->
- (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("STRICT",clt),a) as x)::xs when token2line x = line ->
- (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("any",clt),a) as x)::xs when token2line x = line ->
- (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("ANY",clt),a) as x)::xs when token2line x = line ->
- (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("forall",clt),a) as x)::xs when token2line x = line ->
- (PC.TForall,a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TIdent("exists",clt),a) as x)::xs when token2line x = line ->
- (PC.TExists,a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TComma(clt),a) as x)::xs when token2line x = line ->
- (PC.TComma(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TPArob,a) as x)::xs -> (* no line #, just assume on the same line *)
- x :: (find_line_end inwhen line clt q xs)
- | x::xs when token2line x = line -> x :: (find_line_end inwhen line clt q xs)
- | xs -> (PC.TLineEnd(clt),q)::(insert_line_end xs)
-
-let rec translate_when_true_false = function
- [] -> []
- | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("true",_),_)::xs ->
- (PC.TWhenTrue(clt),q)::x::(translate_when_true_false xs)
- | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("false",_),_)::xs ->
- (PC.TWhenFalse(clt),q)::x::(translate_when_true_false xs)
- | x::xs -> x :: (translate_when_true_false xs)
-
-(* ----------------------------------------------------------------------- *)
-(* top level initializers: a sequence of braces followed by a dot *)
-
-let find_top_init tokens =
- match tokens with
- (PC.TOBrace(clt),q) :: rest ->
- let rec dot_start acc = function
- ((PC.TOBrace(_),_) as x) :: rest ->
- dot_start (x::acc) rest
- | ((PC.TDot(_),_) :: rest) as x ->
- Some ((PC.TOInit(clt),q) :: (List.rev acc) @ x)
- | l -> None in
- let rec comma_end acc = function
- ((PC.TCBrace(_),_) as x) :: rest ->
- comma_end (x::acc) rest
- | ((PC.TComma(_),_) :: rest) as x ->
- Some ((PC.TOInit(clt),q) :: (List.rev x) @ acc)
- | l -> None in
- (match dot_start [] rest with
- Some x -> x
- | None ->
- (match List.rev rest with
- (* not super sure what this does, but EOF, @, and @@ should be
- the same, markind the end of a rule *)
- ((PC.EOF,_) as x)::rest | ((PC.TArob,_) as x)::rest
- | ((PC.TArobArob,_) as x)::rest ->
- (match comma_end [x] rest with
- Some x -> x
- | None -> tokens)
- | _ ->
- failwith "unexpected empty token list"))
- | _ -> tokens
-
-(* ----------------------------------------------------------------------- *)
-(* process pragmas: they can only be used in + code, and adjacent to
-another + token. They are concatenated to the string representation of
-that other token. *)
-
-let rec collect_all_pragmas collected = function
- (PC.TPragma(s),_)::rest -> collect_all_pragmas (s::collected) rest
- | l -> (List.rev collected,l)
-
-let rec collect_up_to_pragmas skipped = function
- [] -> None (* didn't reach a pragma, so nothing to do *)
- | ((PC.TPragma(s),_) as t)::rest ->
- let (pragmas,rest) = collect_all_pragmas [] (t::rest) in
- Some (List.rev skipped,pragmas,rest)
- | x::xs ->
- match plus_attachable x with
- PLUS -> None
- | NOTPLUS -> None
- | SKIP -> collect_up_to_pragmas (x::skipped) xs
-
-let rec collect_up_to_plus skipped = function
- [] -> failwith "nothing to attach a pragma to (empty)"
- | x::xs ->
- match plus_attachable x with
- PLUS -> (List.rev skipped,x,xs)
- | NOTPLUS -> failwith "nothing to attach a pragma to"
- | SKIP -> collect_up_to_plus (x::skipped) xs
-
-let rec process_pragmas = function
- [] -> []
- | ((PC.TPragma(s),_)::_) as l ->
- let (pragmas,rest) = collect_all_pragmas [] l in
- let (skipped,aft,rest) = collect_up_to_plus [] rest in
- let (a,b,c,d,e,strbef,straft,pos) = get_clt aft in
- skipped@
- (process_pragmas ((update_clt aft (a,b,c,d,e,pragmas,straft,pos))::rest))
- | bef::xs ->
- (match plus_attachable bef with
- PLUS ->
- (match collect_up_to_pragmas [] xs with
- Some(skipped,pragmas,rest) ->
- let (a,b,c,d,e,strbef,straft,pos) = get_clt bef in
- (update_clt bef (a,b,c,d,e,strbef,pragmas,pos))::
- skipped@(process_pragmas rest)
- | None -> bef::(process_pragmas xs))
- | _ -> bef::(process_pragmas xs))
-
-(* ----------------------------------------------------------------------- *)
-(* Drop ... ... . This is only allowed in + code, and arises when there is
-some - code between the ... *)
-(* drop whens as well - they serve no purpose in + code and they cause
-problems for drop_double_dots *)
-
-let rec drop_when = function
- [] -> []
- | (PC.TWhen(clt),info)::xs ->
- let rec loop = function
- [] -> []
- | (PC.TLineEnd(_),info)::xs -> drop_when xs
- | x::xs -> loop xs in
- loop xs
- | x::xs -> x::drop_when xs
-
-(* instead of dropping the double dots, we put TNothing in between them.
-these vanish after the parser, but keeping all the ...s in the + code makes
-it easier to align the + and - code in context_neg and in preparation for the
-isomorphisms. This shouldn't matter because the context code of the +
-slice is mostly ignored anyway *)
-let minus_to_nothing l =
- (* for cases like | <..., which may or may not arise from removing minus
- code, depending on whether <... is a statement or expression *)
- let is_minus tok =
- try
- let (d,_,_,_,_,_,_,_) = get_clt tok in
- (match d with
- D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> true
- | D.PLUS -> false
- | D.CONTEXT | D.UNIQUE | D.OPT -> false)
- with _ -> false in
- let rec minus_loop = function
- [] -> []
- | (d::ds) as l -> if is_minus d then minus_loop ds else l in
- let rec loop = function
- [] -> []
- | ((PC.TMid0(clt),i) as x)::t1::ts when is_minus t1 ->
- (match minus_loop ts with
- ((PC.TOEllipsis(_),_)::_) | ((PC.TPOEllipsis(_),_)::_)
- | ((PC.TEllipsis(_),_)::_) as l -> x::(PC.TNothing,i)::(loop l)
- | l -> x::(loop l))
- | t::ts -> t::(loop ts) in
- loop l
-
-let rec drop_double_dots l =
- let start = function
- (PC.TOEllipsis(_),_) | (PC.TPOEllipsis(_),_)
- (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) ->
- true
- | _ -> false in
- let middle = function
- (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true
- | _ -> false in
- let whenline = function
- (PC.TLineEnd(_),_) -> true
- (*| (PC.TMid0(_),_) -> true*)
- | _ -> false in
- let final = function
- (PC.TCEllipsis(_),_) | (PC.TPCEllipsis(_),_)
- (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) ->
- true
- | _ -> false in
- let any_before x = start x or middle x or final x or whenline x in
- let any_after x = start x or middle x or final x in
- let rec loop ((_,i) as prev) = function
- [] -> []
- | x::rest when any_before prev && any_after x ->
- (PC.TNothing,i)::x::(loop x rest)
- | x::rest -> x :: (loop x rest) in
- match l with
- [] -> []
- | (x::xs) -> x :: loop x xs
-
-let rec fix f l =
- let cur = f l in
- if l = cur then l else fix f cur
-
-(* ( | ... | ) also causes parsing problems *)
-
-exception Not_empty
-
-let rec drop_empty_thing starter middle ender = function
- [] -> []
- | hd::rest when starter hd ->
- let rec loop = function
- x::rest when middle x -> loop rest
- | x::rest when ender x -> rest
- | _ -> raise Not_empty in
- (match try Some(loop rest) with Not_empty -> None with
- Some x -> drop_empty_thing starter middle ender x
- | None -> hd :: drop_empty_thing starter middle ender rest)
- | x::rest -> x :: drop_empty_thing starter middle ender rest
-
-let drop_empty_or =
- drop_empty_thing
- (function (PC.TOPar0(_),_) -> true | _ -> false)
- (function (PC.TMid0(_),_) -> true | _ -> false)
- (function (PC.TCPar0(_),_) -> true | _ -> false)
-
-let drop_empty_nest = drop_empty_thing
-
-(* ----------------------------------------------------------------------- *)
-(* Read tokens *)
-
-let get_s_starts (_, (s,_,(starts, ends))) =
- Printf.printf "%d %d\n" starts ends; (s, starts)
-
-let pop2 l =
- let v = List.hd !l in
- l := List.tl !l;
- v
-
-let reinit _ =
- PC.reinit (function _ -> PC.TArobArob (* a handy token *))
- (Lexing.from_function
- (function buf -> function n -> raise Common.Impossible))
-
-let parse_one str parsefn file toks =
- let all_tokens = ref toks in
- let cur_tok = ref (List.hd !all_tokens) in
-
- let lexer_function _ =
- let (v, info) = pop2 all_tokens in
- cur_tok := (v, info);
- v in
-
- let lexbuf_fake =
- Lexing.from_function
- (function buf -> function n -> raise Common.Impossible)
- in
-
- reinit();
-
- try parsefn lexer_function lexbuf_fake
- with
- Lexer_cocci.Lexical s ->
- failwith
- (Printf.sprintf "%s: lexical error: %s\n =%s\n" str s
- (Common.error_message file (get_s_starts !cur_tok) ))
- | Parser_cocci_menhir.Error ->
- failwith
- (Printf.sprintf "%s: parse error: \n = %s\n" str
- (Common.error_message file (get_s_starts !cur_tok) ))
- | Semantic_cocci.Semantic s ->
- failwith
- (Printf.sprintf "%s: semantic error: %s\n =%s\n" str s
- (Common.error_message file (get_s_starts !cur_tok) ))
-
- | e -> raise e
-
-let prepare_tokens tokens =
- find_top_init
- (translate_when_true_false (* after insert_line_end *)
- (insert_line_end
- (detect_types false (find_function_names (detect_attr tokens)))))
-
-let prepare_mv_tokens tokens =
- detect_types false (detect_attr tokens)
-
-let rec consume_minus_positions = function
- [] -> []
- | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs
- | ((PC.TMid0(_),_) as x)::xs -> x::consume_minus_positions xs
- | x::(PC.TPArob,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs ->
- let (arity,ln,lln,offset,col,strbef,straft,_) = get_clt x in
- let name = Parse_aux.clt2mcode name clt in
- let x =
- update_clt x
- (arity,ln,lln,offset,col,strbef,straft,
- Ast0.MetaPos(name,constraints,per)) in
- x::(consume_minus_positions xs)
- | x::xs -> x::consume_minus_positions xs
-
-let any_modif rule =
- let mcode x =
- match Ast0.get_mcode_mcodekind x with
- Ast0.MINUS _ | Ast0.PLUS -> true
- | _ -> false in
- let donothing r k e = k e in
- let bind x y = x or y in
- let option_default = false in
- let fn =
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
- List.exists fn.V0.combiner_top_level rule
-
-let drop_last extra l = List.rev(extra@(List.tl(List.rev l)))
-
-let partition_either l =
- let rec part_either left right = function
- | [] -> (List.rev left, List.rev right)
- | x :: l ->
- (match x with
- | Common.Left e -> part_either (e :: left) right l
- | Common.Right e -> part_either left (e :: right) l) in
- part_either [] [] l
-
-let get_metavars parse_fn table file lexbuf =
- let rec meta_loop acc (* read one decl at a time *) =
- let (_,tokens) =
- tokens_all table file true lexbuf [PC.TArobArob;PC.TMPtVirg] in
- let tokens = prepare_mv_tokens tokens in
- match tokens with
- [(PC.TArobArob,_)] -> List.rev acc
- | _ ->
- let metavars = parse_one "meta" parse_fn file tokens in
- meta_loop (metavars@acc) in
- partition_either (meta_loop [])
-
-let get_script_metavars parse_fn table file lexbuf =
- let rec meta_loop acc =
- let (_, tokens) =
- tokens_all table file true lexbuf [PC.TArobArob; PC.TMPtVirg] in
- let tokens = prepare_tokens tokens in
- match tokens with
- [(PC.TArobArob, _)] -> List.rev acc
- | _ ->
- let metavar = parse_one "scriptmeta" parse_fn file tokens in
- meta_loop (metavar :: acc)
- in
- meta_loop []
-
-let get_rule_name parse_fn starts_with_name get_tokens file prefix =
- Data.in_rule_name := true;
- let mknm _ = make_name prefix (!Lexer_cocci.line) in
- let name_res =
- if starts_with_name
- then
- let (_,tokens) = get_tokens [PC.TArob] in
- let check_name = function
- None -> Some (mknm())
- | Some nm ->
- (if List.mem nm reserved_names
- then failwith (Printf.sprintf "invalid name %s\n" nm));
- Some nm in
- match parse_one "rule name" parse_fn file tokens with
- Ast.CocciRulename (nm,a,b,c,d,e) ->
- Ast.CocciRulename (check_name nm,a,b,c,d,e)
- | Ast.GeneratedRulename (nm,a,b,c,d,e) ->
- Ast.GeneratedRulename (check_name nm,a,b,c,d,e)
- | Ast.ScriptRulename(s,deps) -> Ast.ScriptRulename(s,deps)
- else
- Ast.CocciRulename(Some(mknm()),Ast.NoDep,[],[],Ast.Undetermined,false) in
- Data.in_rule_name := false;
- name_res
-
-let parse_iso file =
- let table = Common.full_charpos_to_pos file in
- Common.with_open_infile file (fun channel ->
- let lexbuf = Lexing.from_channel channel in
- let get_tokens = tokens_all table file false lexbuf in
- let res =
- match get_tokens [PC.TArobArob;PC.TArob] with
- (true,start) ->
- let parse_start start =
- let rev = List.rev start in
- let (arob,_) = List.hd rev in
- (arob = PC.TArob,List.rev(List.tl rev)) in
- let (starts_with_name,start) = parse_start start in
- let rec loop starts_with_name start =
- (!Data.init_rule)();
- (* get metavariable declarations - have to be read before the
- rest *)
- let (rule_name,_,_,_,_,_) =
- match get_rule_name PC.iso_rule_name starts_with_name get_tokens
- file ("iso file "^file) with
- Ast.CocciRulename (Some n,a,b,c,d,e) -> (n,a,b,c,d,e)
- | _ -> failwith "Script rules cannot appear in isomorphism rules"
- in
- Ast0.rule_name := rule_name;
- Data.in_meta := true;
- let iso_metavars =
- match get_metavars PC.iso_meta_main table file lexbuf with
- (iso_metavars,[]) -> iso_metavars
- | _ -> failwith "unexpected inheritance in iso" in
- Data.in_meta := false;
- (* get the rule *)
- let (more,tokens) =
- get_tokens
- [PC.TIsoStatement;PC.TIsoExpression;PC.TIsoArgExpression;
- PC.TIsoTestExpression;
- PC.TIsoDeclaration;PC.TIsoType;PC.TIsoTopLevel] in
- let next_start = List.hd(List.rev tokens) in
- let dummy_info = ("",(-1,-1),(-1,-1)) in
- let tokens = drop_last [(PC.EOF,dummy_info)] tokens in
- let tokens = prepare_tokens (start@tokens) in
- (*
- print_tokens "iso tokens" tokens;
- *)
- let entry = parse_one "iso main" PC.iso_main file tokens in
- let entry = List.map (List.map Test_exps.process_anything) entry in
- if more
- then (* The code below allows a header like Statement list,
- which is more than one word. We don't have that any more,
- but the code is left here in case it is put back. *)
- match get_tokens [PC.TArobArob;PC.TArob] with
- (true,start) ->
- let (starts_with_name,start) = parse_start start in
- (iso_metavars,entry,rule_name) ::
- (loop starts_with_name (next_start::start))
- | _ -> failwith "isomorphism ends early"
- else [(iso_metavars,entry,rule_name)] in
- loop starts_with_name start
- | (false,_) -> [] in
- res)
-
-let parse_iso_files existing_isos iso_files extra_path =
- let get_names = List.map (function (_,_,nm) -> nm) in
- let old_names = get_names existing_isos in
- Data.in_iso := true;
- let (res,_) =
- List.fold_left
- (function (prev,names) ->
- function file ->
- Lexer_cocci.init ();
- let file =
- match file with
- Common.Left(fl) -> Filename.concat extra_path fl
- | Common.Right(fl) -> Filename.concat Config.path fl in
- let current = parse_iso file in
- let new_names = get_names current in
- if List.exists (function x -> List.mem x names) new_names
- then failwith (Printf.sprintf "repeated iso name found in %s" file);
- (current::prev,new_names @ names))
- ([],old_names) iso_files in
- Data.in_iso := false;
- existing_isos@(List.concat (List.rev res))
-
-let parse file =
- let table = Common.full_charpos_to_pos file in
- Common.with_open_infile file (fun channel ->
- let lexbuf = Lexing.from_channel channel in
- let get_tokens = tokens_all table file false lexbuf in
- Data.in_prolog := true;
- let initial_tokens = get_tokens [PC.TArobArob;PC.TArob] in
- Data.in_prolog := false;
- let res =
- match initial_tokens with
- (true,data) ->
- (match List.rev data with
- ((PC.TArobArob as x),_)::_ | ((PC.TArob as x),_)::_ ->
- let iso_files =
- parse_one "iso file names" PC.include_main file data in
-
- let parse_cocci_rule ruletype old_metas
- (rule_name, dependencies, iso, dropiso, exists, is_expression) =
- Ast0.rule_name := rule_name;
- Data.inheritable_positions :=
- rule_name :: !Data.inheritable_positions;
-
- (* get metavariable declarations *)
- Data.in_meta := true;
- let (metavars, inherited_metavars) =
- get_metavars PC.meta_main table file lexbuf in
- Data.in_meta := false;
- Hashtbl.add Data.all_metadecls rule_name metavars;
- Hashtbl.add Lexer_cocci.rule_names rule_name ();
- Hashtbl.add Lexer_cocci.all_metavariables rule_name
- (Hashtbl.fold
- (fun key v rest -> (key,v)::rest)
- Lexer_cocci.metavariables []);
-
- (* get transformation rules *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
- let (minus_tokens, _) = split_token_stream tokens in
- let (_, plus_tokens) =
- split_token_stream (minus_to_nothing tokens) in
-
- let minus_tokens = consume_minus_positions minus_tokens in
- let minus_tokens = prepare_tokens minus_tokens in
- let plus_tokens = prepare_tokens plus_tokens in
-
- (*
- print_tokens "minus tokens" minus_tokens;
- print_tokens "plus tokens" plus_tokens;
- *)
-
- let plus_tokens =
- process_pragmas
- (fix (function x -> drop_double_dots (drop_empty_or x))
- (drop_when plus_tokens)) in
- (*
- print_tokens "plus tokens" plus_tokens;
- Printf.printf "before minus parse\n";
- *)
- let minus_res =
- if is_expression
- then parse_one "minus" PC.minus_exp_main file minus_tokens
- else parse_one "minus" PC.minus_main file minus_tokens in
- (*
- Unparse_ast0.unparse minus_res;
- Printf.printf "before plus parse\n";
- *)
- let plus_res =
- if !Flag.sgrep_mode2
- then (* not actually used for anything, except context_neg *)
- List.map
- (Iso_pattern.rebuild_mcode None).V0.rebuilder_top_level
- minus_res
- else
- if is_expression
- then parse_one "plus" PC.plus_exp_main file plus_tokens
- else parse_one "plus" PC.plus_main file plus_tokens in
- (*
- Printf.printf "after plus parse\n";
- *)
-
- (if not !Flag.sgrep_mode2 &&
- (any_modif minus_res or any_modif plus_res)
- then Data.inheritable_positions := []);
-
- Check_meta.check_meta rule_name old_metas inherited_metavars
- metavars minus_res plus_res;
-
- (more, Ast0.CocciRule ((minus_res, metavars,
- (iso, dropiso, dependencies, rule_name, exists)),
- (plus_res, metavars), ruletype), metavars, tokens) in
-
- let parse_script_rule language old_metas deps =
- let get_tokens = tokens_script_all table file false lexbuf in
-
- (* meta-variables *)
- Data.in_meta := true;
- let metavars =
- get_script_metavars PC.script_meta_main table file lexbuf in
- Data.in_meta := false;
-
- let exists_in old_metas (py,(r,m)) =
- let test (rr,mr) x =
- let (ro,vo) = Ast.get_meta_name x in
- ro = rr && vo = mr in
- List.exists (test (r,m)) old_metas in
-
- List.iter
- (function x ->
- let meta2c (r,n) = Printf.sprintf "%s.%s" r n in
- if not (exists_in old_metas x) then
- failwith
- (Printf.sprintf
- "Script references unknown meta-variable: %s"
- (meta2c(snd x))))
- metavars;
-
- (* script code *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
- let data =
- match List.hd tokens with
- (PC.TScriptData(s),_) -> s
- | (PC.TArobArob,_) | (PC.TArob,_) -> ""
- | _ -> failwith "Malformed script rule" in
- (more,Ast0.ScriptRule(language, deps, metavars, data),[],tokens) in
-
- let parse_rule old_metas starts_with_name =
- let rulename =
- get_rule_name PC.rule_name starts_with_name get_tokens file
- "rule" in
- match rulename with
- Ast.CocciRulename (Some s, a, b, c, d, e) ->
- parse_cocci_rule Ast.Normal old_metas (s, a, b, c, d, e)
- | Ast.GeneratedRulename (Some s, a, b, c, d, e) ->
- Data.in_generating := true;
- let res =
- parse_cocci_rule Ast.Generated old_metas (s,a,b,c,d,e) in
- Data.in_generating := false;
- res
- | Ast.ScriptRulename (l,deps) -> parse_script_rule l old_metas deps
- | _ -> failwith "Malformed rule name"
- in
-
- let rec loop old_metas starts_with_name =
- (!Data.init_rule)();
-
- let gen_starts_with_name more tokens =
- more &&
- (match List.hd (List.rev tokens) with
- (PC.TArobArob,_) -> false
- | (PC.TArob,_) -> true
- | _ -> failwith "unexpected token")
- in
-
- let (more, rule, metavars, tokens) =
- parse_rule old_metas starts_with_name in
- if more then
- rule::
- (loop (metavars @ old_metas) (gen_starts_with_name more tokens))
- else [rule];
-
- in
-
- (iso_files, loop [] (x = PC.TArob))
- | _ -> failwith "unexpected code before the first rule\n")
- | (false,[(PC.TArobArob,_)]) | (false,[(PC.TArob,_)]) ->
- ([],([] : Ast0.parsed_rule list))
- | _ -> failwith "unexpected code before the first rule\n" in
- res)
-
-(* parse to ast0 and then convert to ast *)
-let process file isofile verbose =
- let extra_path = Filename.dirname file in
- Lexer_cocci.init();
- let (iso_files, rules) = parse file in
- let std_isos =
- match isofile with
- None -> []
- | Some iso_file -> parse_iso_files [] [Common.Left iso_file] "" in
- let global_isos = parse_iso_files std_isos iso_files extra_path in
- let rules = Unitary_ast0.do_unitary rules in
- let parsed =
- List.map
- (function
- Ast0.ScriptRule (a,b,c,d) -> [([],Ast.ScriptRule (a,b,c,d))]
- | Ast0.CocciRule
- ((minus, metavarsm,
- (iso, dropiso, dependencies, rule_name, exists)),
- (plus, metavars),ruletype) ->
- let chosen_isos =
- parse_iso_files global_isos
- (List.map (function x -> Common.Left x) iso)
- extra_path in
- let chosen_isos =
- (* check that dropped isos are actually available *)
- (try
- let iso_names =
- List.map (function (_,_,nm) -> nm) chosen_isos in
- let local_iso_names = reserved_names @ iso_names in
- let bad_dropped =
- List.find
- (function dropped ->
- not (List.mem dropped local_iso_names))
- dropiso in
- failwith
- ("invalid iso name " ^ bad_dropped ^ " in " ^ rule_name)
- with Not_found -> ());
- if List.mem "all" dropiso
- then
- if List.length dropiso = 1
- then []
- else failwith "disable all should only be by itself"
- else (* drop those isos *)
- List.filter
- (function (_,_,nm) -> not (List.mem nm dropiso))
- chosen_isos in
- List.iter Iso_compile.process chosen_isos;
- let dropped_isos =
- match reserved_names with
- "all"::others ->
- (match dropiso with
- ["all"] -> others
- | _ ->
- List.filter (function x -> List.mem x dropiso) others)
- | _ ->
- failwith
- "bad list of reserved names - all must be at start" in
- let minus = Test_exps.process minus in
- let minus = Compute_lines.compute_lines minus in
- let plus = Compute_lines.compute_lines plus in
- let is_exp =
- (* only relevant to Flag.make_hrule *)
- (* doesn't handle multiple minirules properly, but since
- we don't really handle them in lots of other ways, it
- doesn't seem very important *)
- match plus with
- [] -> [false]
- | p::_ ->
- [match Ast0.unwrap p with
- Ast0.CODE c ->
- (match List.map Ast0.unwrap (Ast0.undots c) with
- [Ast0.Exp e] -> true | _ -> false)
- | _ -> false] in
- let minus = Arity.minus_arity minus in
- let ((metavars,minus),function_prototypes) =
- Function_prototypes.process
- rule_name metavars dropped_isos minus plus ruletype in
- (* warning! context_neg side-effects its arguments *)
- let (m,p) = List.split (Context_neg.context_neg minus plus) in
- Type_infer.type_infer p;
- (if not !Flag.sgrep_mode2
- then Insert_plus.insert_plus m p (chosen_isos = []));
- Type_infer.type_infer minus;
- let (extra_meta, minus) =
- match (chosen_isos,ruletype) with
- (* separate case for [] because applying isos puts
- some restrictions on the -+ code *)
- ([],_) | (_,Ast.Generated) -> ([],minus)
- | _ -> Iso_pattern.apply_isos chosen_isos minus rule_name in
- let minus = Comm_assoc.comm_assoc minus rule_name dropiso in
- let minus =
- if !Flag.sgrep_mode2 then minus
- else Single_statement.single_statement minus in
- let minus = Simple_assignments.simple_assignments minus in
- let minus_ast =
- Ast0toast.ast0toast rule_name dependencies dropped_isos
- exists minus is_exp ruletype in
- match function_prototypes with
- None -> [(extra_meta @ metavars, minus_ast)]
- | Some mv_fp ->
- [(extra_meta @ metavars, minus_ast); mv_fp])
-(* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*)
- rules in
- let parsed = List.concat parsed in
- let disjd = Disjdistr.disj parsed in
-
- let (metavars,code,fvs,neg_pos,ua,pos) = Free_vars.free_vars disjd in
- if !Flag_parsing_cocci.show_SP
- then List.iter Pretty_print_cocci.unparse code;
-
- let grep_tokens =
- Common.profile_code "get_constants"
- (fun () -> Get_constants.get_constants code) in (* for grep *)
- let glimpse_tokens2 =
- Common.profile_code "get_glimpse_constants"
- (fun () -> Get_constants2.get_constants code neg_pos) in(* for glimpse *)
- (metavars,code,fvs,neg_pos,ua,pos,grep_tokens,glimpse_tokens2)
+++ /dev/null
-/*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*/
-
-
-%{
-
-(* Not clear how to allow function declarations to specify a return type
-and how to allow both to be specified as static, because they are in
-different rules. The rules seem to have to be combined, which would allow
-functions to be declared as local variables *)
-
-(* Not clear how to let a function have a parameter of type void. At the
-moment, void is allowed to be the type of a variable, which is wrong, and a
-parameter needs both a type and an identifier *)
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module P = Parse_aux
-%}
-
-%token EOF
-
-%token TIdentifier TExpression TStatement TFunction TLocal TType TParameter
-%token TIdExpression
-%token Tlist TFresh TConstant TError TWords TWhy0 TPlus0 TBang0
-%token TPure TContext TGenerated
-%token TTypedef TDeclarer TIterator TName TPosition TPosAny
-%token TUsing TDisable TExtends TDepends TOn TEver TNever TExists TForall
-%token TScript TReverse TNothing
-%token<string> TRuleName
-
-%token<Data.clt> Tchar Tshort Tint Tdouble Tfloat Tlong
-%token<Data.clt> Tvoid Tstruct Tunion Tenum
-%token<Data.clt> Tunsigned Tsigned
-
-%token<Data.clt> Tstatic Tauto Tregister Textern Tinline Ttypedef
-%token<Data.clt> Tconst Tvolatile
-%token<string * Data.clt> Tattr
-
-%token <Data.clt> TIf TElse TWhile TFor TDo TSwitch TCase TDefault TReturn
-%token <Data.clt> TBreak TContinue TGoto TSizeof TFunDecl
-%token <string * Data.clt> TIdent TTypeId TDeclarerId TIteratorId
-
-%token <Parse_aux.idinfo> TMetaId TMetaFunc TMetaLocalFunc
-%token <Parse_aux.idinfo> TMetaIterator TMetaDeclarer
-%token <Parse_aux.expinfo> TMetaErr
-%token <Parse_aux.info> TMetaParam TMetaStm TMetaStmList TMetaType
-%token <Parse_aux.list_info> TMetaParamList TMetaExpList
-%token <Parse_aux.typed_info> TMetaExp TMetaIdExp TMetaLocalIdExp TMetaConst
-%token <Parse_aux.pos_info> TMetaPos
-
-%token TArob TArobArob TPArob
-%token <string> TScriptData
-
-%token <Data.clt> TEllipsis TOEllipsis TCEllipsis TPOEllipsis TPCEllipsis
-%token <Data.clt> TWhen TWhenTrue TWhenFalse TAny TStrict TLineEnd
-
-%token <Data.clt> TWhy TDotDot TBang TOPar TOPar0
-%token <Data.clt> TMid0 TCPar TCPar0
-
-%token <string> TPragma TPathIsoFile
-%token <string * Data.clt> TIncludeL TIncludeNL
-%token <Data.clt * token> TDefine
-%token <Data.clt * token * int> TDefineParam
-%token <string * Data.clt> TMinusFile TPlusFile
-
-%token <Data.clt> TInc TDec
-
-%token <string * Data.clt> TString TChar TFloat TInt
-
-%token <Data.clt> TOrLog
-%token <Data.clt> TAndLog
-%token <Data.clt> TOr
-%token <Data.clt> TXor
-%token <Data.clt> TAnd
-%token <Data.clt> TEqEq TNotEq
-%token <Ast_cocci.logicalOp * Data.clt> TLogOp /* TInf TSup TInfEq TSupEq */
-%token <Ast_cocci.arithOp * Data.clt> TShOp /* TShl TShr */
-%token <Ast_cocci.arithOp * Data.clt> TDmOp /* TDiv TMod */
-%token <Data.clt> TPlus TMinus
-%token <Data.clt> TMul TTilde
-
-%token <Data.clt> TOBrace TCBrace TOInit
-%token <Data.clt> TOCro TCCro
-
-%token <Data.clt> TPtrOp
-
-%token TMPtVirg
-%token <Data.clt> TEq TDot TComma TPtVirg
-%token <Ast_cocci.assignOp * Data.clt> TAssign
-
-%token TIso TRightIso TIsoExpression TIsoStatement TIsoDeclaration TIsoType
-%token TIsoTopLevel TIsoArgExpression TIsoTestExpression
-
-%token TInvalid
-
-/* operator precedence */
-%nonassoc TIf
-%nonassoc TElse
-
-%left TOrLog
-%left TAndLog
-%left TOr
-%left TXor
-%left TAnd
-%left TEqEq TNotEq
-%left TLogOp /* TInf TSup TInfEq TSupEq */
-%left TShOp /* TShl TShr */
-%left TPlus TMinus
-%left TMul TDmOp /* TDiv TMod */
-
-%start reinit
-%type <unit> reinit
-
-%start minus_main
-%type <Ast0_cocci.rule> minus_main
-
-%start minus_exp_main
-%type <Ast0_cocci.rule> minus_exp_main
-
-%start plus_main
-%type <Ast0_cocci.rule> plus_main
-
-%start plus_exp_main
-%type <Ast0_cocci.rule> plus_exp_main
-
-%start include_main
-%type <(string,string) Common.either list> include_main
-
-%start iso_rule_name
-%type <Ast_cocci.rulename>
-iso_rule_name
-
-%start rule_name
-%type <Ast_cocci.rulename>
-rule_name
-
-%start meta_main
-%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> meta_main
-
-%start <string * (string * string)> script_meta_main
-
-%start iso_main
-%type <Ast0_cocci.anything list list> iso_main
-
-%start iso_meta_main
-%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> iso_meta_main
-
-%start never_used
-%type <unit> never_used
-
-%%
-
-reinit: { }
-minus_main: minus_body EOF { $1 } | m=minus_body TArobArob { m }
-| m=minus_body TArob { m }
-plus_main: plus_body EOF { $1 } | p=plus_body TArobArob { p }
-| p=plus_body TArob { p }
-minus_exp_main: minus_exp_body EOF { $1 } | m=minus_exp_body TArobArob { m }
-| m=minus_exp_body TArob { m }
-plus_exp_main: plus_exp_body EOF { $1 } | p=plus_exp_body TArobArob { p }
-| p=plus_exp_body TArob { p }
-meta_main: m=metadec { m (!Ast0.rule_name) }
-iso_meta_main: m=metadec { m "" }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-pure:
- TPure { Ast0.Pure }
-| TContext { Ast0.Context }
-| TPure TContext { Ast0.PureContext }
-| TContext TPure { Ast0.PureContext }
-| /* empty */ { Ast0.Impure }
-
-iso_rule_name:
- nm=pure_ident TArob { P.make_iso_rule_name_result (P.id2name nm) }
-
-rule_name:
- nm=ioption(pure_ident) extends d=depends i=loption(choose_iso)
- a=loption(disable) e=exists ee=is_expression TArob
- { P.make_cocci_rule_name_result nm d i a e ee }
- | TGenerated extends d=depends i=loption(choose_iso)
- a=loption(disable) e=exists ee=is_expression TArob
- /* these rules have no name as a cheap way to ensure that no normal
- rule inherits their metavariables or depends on them */
- { P.make_generated_rule_name_result None d i a e ee }
- | TScript TDotDot lang=pure_ident d=depends TArob
- { P.make_script_rule_name_result lang d }
-
-extends:
- /* empty */ { () }
-| TExtends parent=TRuleName
- { !Data.install_bindings (parent) }
-
-depends:
- /* empty */ { Ast.NoDep }
-| TDepends TOn parents=dep { parents }
-
-dep:
- pnrule { $1 }
-| dep TAndLog dep { Ast.AndDep($1, $3) }
-| dep TOrLog dep { Ast.OrDep ($1, $3) }
-
-pnrule:
- TRuleName { Ast.Dep $1 }
-| TBang TRuleName { Ast.AntiDep $2 }
-| TEver TRuleName { Ast.EverDep $2 }
-| TNever TRuleName { Ast.NeverDep $2 }
-| TOPar dep TCPar { $2 }
-
-choose_iso:
- TUsing separated_nonempty_list(TComma,TString) { List.map P.id2name $2 }
-
-disable:
- TDisable separated_nonempty_list(TComma,pure_ident) { List.map P.id2name $2 }
-
-exists:
- TExists { Ast.Exists }
-| TForall { Ast.Forall }
-| TReverse TForall { Ast.ReverseForall }
-| { Ast.Undetermined }
-
-is_expression: // for more flexible parsing of top level expressions
- { false }
-| TExpression { true }
-
-include_main:
- list(incl) TArob { $1 }
-| list(incl) TArobArob { $1 }
-
-incl:
- TUsing TString { Common.Left(P.id2name $2) }
-| TUsing TPathIsoFile { Common.Right $2 }
-
-metadec:
- ar=arity ispure=pure
- kindfn=metakind ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_metadec ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_eq)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic_expi
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_eqe)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic_expe
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_ceq)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity TPosition a=option(TPosAny)
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_pos)) TMPtVirg
- (* pb: position variables can't be inherited from normal rules, and then
- there is no way to inherit from a generated rule, so there is no point
- to have a position variable *)
- { (if !Data.in_generating
- then failwith "position variables not allowed in a generated rule file");
- let kindfn arity name pure check_meta constraints =
- let tok = check_meta(Ast.MetaPosDecl(arity,name)) in
- let any = match a with None -> Ast.PER | Some _ -> Ast.ALL in
- !Data.add_pos_meta name constraints any; tok in
- P.create_metadec_ne ar false kindfn ids }
-| ar=arity ispure=pure
- TParameter Tlist TOCro id=pure_ident_or_meta_ident TCCro
- ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_len_metadec ar ispure
- (fun lenname arity name pure check_meta ->
- let tok =
- check_meta(Ast.MetaParamListDecl(arity,name,Some lenname)) in
- !Data.add_paramlist_meta name (Some lenname) pure; tok)
- id ids }
-| ar=arity ispure=pure
- TExpression Tlist TOCro id=pure_ident_or_meta_ident TCCro
- ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_len_metadec ar ispure
- (fun lenname arity name pure check_meta ->
- let tok =
- check_meta(Ast.MetaExpListDecl(arity,name,Some lenname)) in
- !Data.add_explist_meta name (Some lenname) pure; tok)
- id ids }
-
-%inline metakind:
- TFresh TIdentifier
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaFreshIdDecl(arity,name)) in
- !Data.add_id_meta name [] pure; tok) }
-| TParameter
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaParamDecl(arity,name)) in
- !Data.add_param_meta name pure; tok) }
-| TParameter Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaParamListDecl(arity,name,None)) in
- !Data.add_paramlist_meta name None pure; tok) }
-| TExpression Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaExpListDecl(arity,name,None)) in
- !Data.add_explist_meta name None pure; tok) }
-| TType
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaTypeDecl(arity,name)) in
- !Data.add_type_meta name pure; tok) }
-| TStatement
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaStmDecl(arity,name)) in
- !Data.add_stm_meta name pure; tok) }
-| TStatement Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaStmListDecl(arity,name)) in
- !Data.add_stmlist_meta name pure; tok) }
-| TTypedef
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_type_name name; [])
- else raise (Semantic_cocci.Semantic "bad typedef")) }
-| TDeclarer TName
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_declarer_name name; [])
- else raise (Semantic_cocci.Semantic "bad declarer")) }
-| TIterator TName
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_iterator_name name; [])
- else raise (Semantic_cocci.Semantic "bad iterator")) }
-
-
-%inline metakind_atomic:
- TIdentifier
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaIdDecl(arity,name)) in
- !Data.add_id_meta name constraints pure; tok) }
-| TFunction
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaFuncDecl(arity,name)) in
- !Data.add_func_meta name constraints pure; tok) }
-| TLocal TFunction
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaLocalFuncDecl(arity,name)) in
- !Data.add_local_func_meta name constraints pure;
- tok) }
-| TDeclarer
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaDeclarerDecl(arity,name)) in
- !Data.add_declarer_meta name constraints pure; tok) }
-| TIterator
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaIteratorDecl(arity,name)) in
- !Data.add_iterator_meta name constraints pure; tok) }
-
-%inline metakind_atomic_expi:
- TError
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaErrDecl(arity,name)) in
- !Data.add_err_meta name constraints pure; tok) }
-| l=option(TLocal) TIdExpression ty=ioption(meta_exp_type)
- { (fun arity name pure check_meta constraints ->
- match l with
- None ->
- !Data.add_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaIdExpDecl(arity,name,ty))
- | Some _ ->
- !Data.add_local_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaLocalIdExpDecl(arity,name,ty))) }
-| l=option(TLocal) TIdExpression m=nonempty_list(TMul)
- { (fun arity name pure check_meta constraints ->
- let ty = Some [P.ty_pointerify Type_cocci.Unknown m] in
- match l with
- None ->
- !Data.add_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaIdExpDecl(arity,name,ty))
- | Some _ ->
- !Data.add_local_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaLocalIdExpDecl(arity,name,ty))) }
-| TExpression m=nonempty_list(TMul)
- { (fun arity name pure check_meta constraints ->
- let ty = Some [P.ty_pointerify Type_cocci.Unknown m] in
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-| vl=meta_exp_type TOCro TCCro
- { (fun arity name pure check_meta constraints ->
- let ty = Some (List.map (function x -> Type_cocci.Array x) vl) in
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-| TConstant ty=ioption(meta_exp_type)
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaConstDecl(arity,name,ty)) in
- !Data.add_const_meta ty name constraints pure; tok) }
-
-%inline metakind_atomic_expe:
- TExpression
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaExpDecl(arity,name,None)) in
- !Data.add_exp_meta None name constraints pure; tok) }
-| vl=meta_exp_type // no error if use $1 but doesn't type check
- { (fun arity name pure check_meta constraints ->
- let ty = Some vl in
- List.iter
- (function c ->
- match Ast0.unwrap c with
- Ast0.Constant(_) ->
- if not
- (List.exists
- (function
- Type_cocci.BaseType(Type_cocci.IntType) -> true
- | Type_cocci.BaseType(Type_cocci.ShortType) -> true
- | Type_cocci.BaseType(Type_cocci.LongType) -> true
- | _ -> false)
- vl)
- then failwith "metavariable with int constraint must be an int"
- | _ -> ())
- constraints;
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-
-
-meta_exp_type:
- t=ctype
- { [Ast0_cocci.ast0_type_to_type t] }
-| TOBrace t=comma_list(ctype) TCBrace m=list(TMul)
- { List.map
- (function x -> P.ty_pointerify (Ast0_cocci.ast0_type_to_type x) m)
- t }
-
-arity: TBang0 { Ast.UNIQUE }
- | TWhy0 { Ast.OPT }
- | TPlus0 { Ast.MULTI }
- | /* empty */ { Ast.NONE }
-
-generic_ctype_full:
- q=ctype_qualif_opt ty=Tchar
- { q (Ast0.wrap(Ast0.BaseType(Ast.CharType,[P.clt2mcode "char" ty]))) }
- | q=ctype_qualif_opt ty=Tshort
- { q (Ast0.wrap(Ast0.BaseType(Ast.ShortType,[P.clt2mcode "short" ty])))}
- | q=ctype_qualif_opt ty=Tint
- { q (Ast0.wrap(Ast0.BaseType(Ast.IntType,[P.clt2mcode "int" ty]))) }
- | t=Tdouble
- { Ast0.wrap(Ast0.BaseType(Ast.DoubleType,[P.clt2mcode "double" t])) }
- | t=Tfloat
- { Ast0.wrap(Ast0.BaseType(Ast.FloatType,[P.clt2mcode "float" t])) }
- | q=ctype_qualif_opt ty=Tlong
- { q (Ast0.wrap(Ast0.BaseType(Ast.LongType,[P.clt2mcode "long" ty]))) }
- | q=ctype_qualif_opt ty=Tlong ty1=Tlong
- { q (Ast0.wrap
- (Ast0.BaseType
- (Ast.LongLongType,
- [P.clt2mcode "long" ty;P.clt2mcode "long" ty1]))) }
- | s=Tenum i=ident
- { Ast0.wrap(Ast0.EnumName(P.clt2mcode "enum" s, i)) }
- | s=struct_or_union i=ident
- { Ast0.wrap(Ast0.StructUnionName(s, Some i)) }
- | s=struct_or_union i=ioption(ident)
- l=TOBrace d=struct_decl_list r=TCBrace
- { (if i = None && !Data.in_iso
- then failwith "structures must be named in the iso file");
- Ast0.wrap(Ast0.StructUnionDef(Ast0.wrap(Ast0.StructUnionName(s, i)),
- P.clt2mcode "{" l,
- d, P.clt2mcode "}" r)) }
- | s=TMetaType l=TOBrace d=struct_decl_list r=TCBrace
- { let (nm,pure,clt) = s in
- let ty =
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure)) in
- Ast0.wrap
- (Ast0.StructUnionDef(ty,P.clt2mcode "{" l,d,P.clt2mcode "}" r)) }
- | r=TRuleName TDot p=TIdent
- { let nm = (r,P.id2name p) in
- (* this is only possible when we are in a metavar decl. Otherwise,
- it will be represented already as a MetaType *)
- let _ = P.check_meta(Ast.MetaTypeDecl(Ast.NONE,nm)) in
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm (P.id2clt p),
- Ast0.Impure (*will be ignored*))) }
- | p=TTypeId
- { Ast0.wrap(Ast0.TypeName(P.id2mcode p)) }
- | q=ctype_qualif_opt p=TMetaType
- { let (nm,pure,clt) = p in
- q (Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure))) }
-
-generic_ctype:
- q=ctype_qualif { q None }
- | generic_ctype_full { $1 }
-
-struct_or_union:
- s=Tstruct { P.clt2mcode Ast.Struct s }
- | u=Tunion { P.clt2mcode Ast.Union u }
-
-struct_decl:
- TNothing { [] }
- | t=ctype d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- [Ast0.wrap(Ast0.UnInit(None,fn t,id,P.clt2mcode ";" pv))] }
- | t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.UnInit(None,fn t,id,P.clt2mcode ";" pv))] }
- | cv=ioption(const_vol) i=pure_ident d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- [Ast0.wrap(Ast0.UnInit(None,fn idtype,id,P.clt2mcode ";" pv))] }
-
-struct_decl_list:
- struct_decl_list_start { Ast0.wrap(Ast0.DOTS($1)) }
-
-struct_decl_list_start:
- struct_decl { $1 }
-| struct_decl struct_decl_list_start { $1@$2 }
-| d=edots_when(TEllipsis,struct_decl) r=continue_struct_decl_list
- { (P.mkddots "..." d)::r }
-
-continue_struct_decl_list:
- /* empty */ { [] }
-| struct_decl struct_decl_list_start { $1@$2 }
-| struct_decl { $1 }
-
-ctype:
- cv=ioption(const_vol) ty=generic_ctype m=list(TMul)
- { P.pointerify (P.make_cv cv ty) m }
- | cv=ioption(const_vol) t=Tvoid m=nonempty_list(TMul)
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- P.pointerify (P.make_cv cv ty) m }
- | lp=TOPar0 t=midzero_list(ctype,ctype) rp=TCPar0
- /* more hacks */
- { let (mids,code) = t in
- Ast0.wrap
- (Ast0.DisjType(P.clt2mcode "(" lp,code,mids, P.clt2mcode ")" rp)) }
-
-ctype_full:
- cv=ioption(const_vol) ty=generic_ctype_full m=list(TMul)
- { P.pointerify (P.make_cv cv ty) m }
- | cv=ioption(const_vol) t=Tvoid m=nonempty_list(TMul)
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- P.pointerify (P.make_cv cv ty) m }
- | lp=TOPar0 t=midzero_list(ctype,ctype) rp=TCPar0
- /* more hacks */
- { let (mids,code) = t in
- Ast0.wrap
- (Ast0.DisjType(P.clt2mcode "(" lp,code,mids, P.clt2mcode ")" rp)) }
-
-
-fn_ctype: // allows metavariables
- ty=generic_ctype m=list(TMul) { P.pointerify ty m }
- | t=Tvoid m=list(TMul)
- { P.pointerify
- (Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])))
- m }
-
-%inline ctype_qualif:
- r=Tunsigned
- { function x -> Ast0.wrap(Ast0.Signed(P.clt2mcode Ast.Unsigned r,x)) }
-| r=Tsigned
- { function x -> Ast0.wrap(Ast0.Signed(P.clt2mcode Ast.Signed r,x)) }
-
-%inline ctype_qualif_opt:
- s=ctype_qualif { function x -> s (Some x) }
-| /* empty */ { function x -> x }
-
-/*****************************************************************************/
-
-/* have to inline everything to avoid conflicts? switch to proper
-declarations, statements, and expressions for the subterms */
-
-minus_body:
- f=loption(filespec)
- b=loption(minus_start)
- ew=loption(error_words)
- { match f@b@ew with
- [] -> raise (Semantic_cocci.Semantic "minus slice can't be empty")
- | code -> Top_level.top_level code }
-
-plus_body:
- f=loption(filespec)
- b=loption(plus_start)
- ew=loption(error_words)
- { Top_level.top_level (f@b@ew) }
-
-minus_exp_body:
- f=loption(filespec)
- b=top_eexpr
- ew=loption(error_words)
- { match f@[b]@ew with
- [] -> raise (Semantic_cocci.Semantic "minus slice can't be empty")
- | code -> Top_level.top_level code }
-
-plus_exp_body:
- f=loption(filespec)
- b=top_eexpr
- ew=loption(error_words)
- { Top_level.top_level (f@[b]@ew) }
-
-filespec:
- TMinusFile TPlusFile
- { [Ast0.wrap
- (Ast0.FILEINFO(P.id2mcode $1,
- P.id2mcode $2))] }
-
-includes:
- TIncludeL
- { Ast0.wrap
- (Ast0.Include(P.clt2mcode "#include" (P.drop_aft (P.id2clt $1)),
- let (arity,ln,lln,offset,col,strbef,straft,pos) =
- P.id2clt $1 in
- let clt =
- (arity,ln,lln,offset,0,strbef,straft,pos) in
- P.clt2mcode
- (Ast.Local (Parse_aux.str2inc (P.id2name $1)))
- (P.drop_bef clt))) }
-| TIncludeNL
- { Ast0.wrap
- (Ast0.Include(P.clt2mcode "#include" (P.drop_aft (P.id2clt $1)),
- let (arity,ln,lln,offset,col,strbef,straft,pos) =
- P.id2clt $1 in
- let clt =
- (arity,ln,lln,offset,0,strbef,straft,pos) in
- P.clt2mcode
- (Ast.NonLocal (Parse_aux.str2inc (P.id2name $1)))
- (P.drop_bef clt))) }
-| d=defineop t=ctype TLineEnd
- { let ty = Ast0.wrap(Ast0.TopExp(Ast0.wrap(Ast0.TypeExp(t)))) in
- d (Ast0.wrap(Ast0.DOTS([ty]))) }
-| defineop b=toplevel_seq_start(toplevel_after_dots) TLineEnd
- { let body =
- match b with
- [e] ->
- (match Ast0.unwrap e with
- Ast0.Exp(e1) ->
- [Ast0.rewrap e (Ast0.TopExp(Ast0.set_arg_exp (e1)))]
- | _ -> b)
- | _ -> b in
- $1 (Ast0.wrap(Ast0.DOTS(body))) }
-
-defineop:
- TDefine
- { let (clt,ident) = $1 in
- function body ->
- Ast0.wrap
- (Ast0.Define
- (P.clt2mcode "#define" clt,
- (match ident with
- TMetaId((nm,constraints,pure,clt)) ->
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure))
- | TIdent(nm_pure) ->
- Ast0.wrap(Ast0.Id(P.id2mcode nm_pure))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "unexpected name for a #define")),
- Ast0.wrap Ast0.NoParams,
- body)) }
-| TDefineParam define_param_list_option TCPar
- { let (clt,ident,parenoff) = $1 in
- let (arity,line,lline,offset,col,strbef,straft,pos) = clt in
- let lp =
- P.clt2mcode "(" (arity,line,lline,parenoff,0,[],[],Ast0.NoMetaPos) in
- function body ->
- Ast0.wrap
- (Ast0.Define
- (P.clt2mcode "#define" clt,
- (match ident with
- TMetaId((nm,constraints,pure,clt)) ->
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure))
- | TIdent(nm_pure) ->
- Ast0.wrap(Ast0.Id(P.id2mcode nm_pure))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "unexpected name for a #define")),
- Ast0.wrap (Ast0.DParams (lp,$2,P.clt2mcode ")" $3)),body)) }
-
-/* ---------------------------------------------------------------------- */
-
-define_param_list: define_param_list_start
- {let circle x =
- match Ast0.unwrap x with Ast0.DPcircles(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-define_param_list_start:
- ident { [Ast0.wrap(Ast0.DParam $1)] }
- | ident TComma define_param_list_start
- { Ast0.wrap(Ast0.DParam $1)::
- Ast0.wrap(Ast0.DPComma(P.clt2mcode "," $2))::$3 }
- | d=TEllipsis r=list(dp_comma_args(TEllipsis))
- { (P.mkdpdots "..." d)::
- (List.concat (List.map (function x -> x (P.mkdpdots "...")) r)) }
-
-dp_comma_args(dotter):
- c=TComma d=dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.DPComma(P.clt2mcode "," c)); dot_builder d] }
-| TComma ident
- { function dot_builder ->
- [Ast0.wrap(Ast0.DPComma(P.clt2mcode "," $1));
- Ast0.wrap(Ast0.DParam $2)] }
-
-define_param_list_option: define_param_list { $1 }
- | /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-
-/*****************************************************************************/
-
-funproto:
- s=ioption(storage) t=ctype
- id=func_ident lp=TOPar d=decl_list(name_opt_decl) rp=TCPar pt=TPtVirg
- { Ast0.wrap
- (Ast0.UnInit
- (s,
- Ast0.wrap
- (Ast0.FunctionType(Some t,
- P.clt2mcode "(" lp, d, P.clt2mcode ")" rp)),
- id, P.clt2mcode ";" pt)) }
-| s=ioption(storage) t=Tvoid
- id=func_ident lp=TOPar d=decl_list(name_opt_decl) rp=TCPar pt=TPtVirg
- { let t = Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- Ast0.wrap
- (Ast0.UnInit
- (s,
- Ast0.wrap
- (Ast0.FunctionType(Some t,
- P.clt2mcode "(" lp, d, P.clt2mcode ")" rp)),
- id, P.clt2mcode ";" pt)) }
-
-
-fundecl:
- f=fninfo
- TFunDecl i=func_ident lp=TOPar d=decl_list(decl) rp=TCPar
- lb=TOBrace b=fun_start rb=TCBrace
- { Ast0.wrap(Ast0.FunDecl((Ast0.default_info(),Ast0.context_befaft()),
- f, i,
- P.clt2mcode "(" lp, d,
- P.clt2mcode ")" rp,
- P.clt2mcode "{" lb, b,
- P.clt2mcode "}" rb)) }
-
-fninfo:
- /* empty */ { [] }
- | storage fninfo
- { try
- let _ =
- List.find (function Ast0.FStorage(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate storage")
- with Not_found -> (Ast0.FStorage($1))::$2 }
- | t=fn_ctype r=fninfo_nt { (Ast0.FType(t))::r }
- | Tinline fninfo
- { try
- let _ = List.find (function Ast0.FInline(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate inline")
- with Not_found -> (Ast0.FInline(P.clt2mcode "inline" $1))::$2 }
- | Tattr fninfo
- { try
- let _ = List.find (function Ast0.FAttr(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "multiple attributes")
- with Not_found -> (Ast0.FAttr(P.id2mcode $1))::$2 }
-
-fninfo_nt:
- /* empty */ { [] }
- | storage fninfo_nt
- { try
- let _ =
- List.find (function Ast0.FStorage(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate storage")
- with Not_found -> (Ast0.FStorage($1))::$2 }
- | Tinline fninfo_nt
- { try
- let _ = List.find (function Ast0.FInline(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate inline")
- with Not_found -> (Ast0.FInline(P.clt2mcode "inline" $1))::$2 }
- | Tattr fninfo_nt
- { try
- let _ = List.find (function Ast0.FAttr(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate init")
- with Not_found -> (Ast0.FAttr(P.id2mcode $1))::$2 }
-
-storage:
- s=Tstatic { P.clt2mcode Ast.Static s }
- | s=Tauto { P.clt2mcode Ast.Auto s }
- | s=Tregister { P.clt2mcode Ast.Register s }
- | s=Textern { P.clt2mcode Ast.Extern s }
-
-decl: t=ctype i=ident
- { Ast0.wrap(Ast0.Param(t, Some i)) }
- | t=fn_ctype lp=TOPar s=TMul i=ident rp=TCPar
- lp1=TOPar d=decl_list(name_opt_decl) rp1=TCPar
- { let fnptr =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp,P.clt2mcode "*" s,P.clt2mcode ")" rp,
- P.clt2mcode "(" lp1,d,P.clt2mcode ")" rp1)) in
- Ast0.wrap(Ast0.Param(fnptr, Some i)) }
- | t=Tvoid
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- Ast0.wrap(Ast0.VoidParam(ty)) }
- | TMetaParam
- { let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaParam(P.clt2mcode nm clt,pure)) }
-
-name_opt_decl:
- decl { $1 }
- | t=ctype { Ast0.wrap(Ast0.Param(t, None)) }
- | t=fn_ctype lp=TOPar s=TMul rp=TCPar
- lp1=TOPar d=decl_list(name_opt_decl) rp1=TCPar
- { let fnptr =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp,P.clt2mcode "*" s,P.clt2mcode ")" rp,
- P.clt2mcode "(" lp1,d,P.clt2mcode ")" rp1)) in
- Ast0.wrap(Ast0.Param(fnptr, None)) }
-
-const_vol:
- Tconst { P.clt2mcode Ast.Const $1 }
- | Tvolatile { P.clt2mcode Ast.Volatile $1 }
-
-/*****************************************************************************/
-
-statement:
- includes { $1 } /* shouldn't be allowed to be a single_statement... */
-| TMetaStm
- { P.meta_stm $1 }
-| expr TPtVirg
- { P.exp_stm $1 $2 }
-| TIf TOPar eexpr TCPar single_statement %prec TIf
- { P.ifthen $1 $2 $3 $4 $5 }
-| TIf TOPar eexpr TCPar single_statement TElse single_statement
- { P.ifthenelse $1 $2 $3 $4 $5 $6 $7 }
-| TFor TOPar option(eexpr) TPtVirg option(eexpr) TPtVirg
- option(eexpr) TCPar single_statement
- { P.forloop $1 $2 $3 $4 $5 $6 $7 $8 $9 }
-| TWhile TOPar eexpr TCPar single_statement
- { P.whileloop $1 $2 $3 $4 $5 }
-| TDo single_statement TWhile TOPar eexpr TCPar TPtVirg
- { P.doloop $1 $2 $3 $4 $5 $6 $7 }
-| iter_ident TOPar eexpr_list_option TCPar single_statement
- { P.iterator $1 $2 $3 $4 $5 }
-| TSwitch TOPar eexpr TCPar TOBrace list(case_line) TCBrace
- { P.switch $1 $2 $3 $4 $5 $6 $7 }
-| TReturn eexpr TPtVirg { P.ret_exp $1 $2 $3 }
-| TReturn TPtVirg { P.ret $1 $2 }
-| TBreak TPtVirg { P.break $1 $2 }
-| TContinue TPtVirg { P.cont $1 $2 }
-| ident TDotDot { P.label $1 $2 }
-| TGoto ident TPtVirg { P.goto $1 $2 $3 }
-| TOBrace fun_start TCBrace
- { P.seq $1 $2 $3 }
-
-stm_dots:
- TEllipsis w=list(whenppdecs)
- { Ast0.wrap(Ast0.Dots(P.clt2mcode "..." $1, List.concat w)) }
-| TOEllipsis w=list(whenppdecs) b=nest_start c=TCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<..." $1, b,
- P.clt2mcode "...>" c, List.concat w, false)) }
-| TPOEllipsis w=list(whenppdecs) b=nest_start c=TPCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<+..." $1, b,
- P.clt2mcode "...+>" c, List.concat w, true)) }
-
-%inline stm_dots_ell:
- a=TEllipsis w=list(whenppdecs)
- { Ast0.wrap(Ast0.Dots(P.clt2mcode "..." a, List.concat w)) }
-
-%inline stm_dots_nest:
- a=TOEllipsis w=list(whenppdecs) b=nest_start c=TCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<..." a, b,
- P.clt2mcode "...>" c, List.concat w, false)) }
-| a=TPOEllipsis w=list(whenppdecs) b=nest_start c=TPCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<+..." a, b,
- P.clt2mcode "...+>" c, List.concat w, true)) }
-
-whenppdecs: w=whens(when_start,rule_elem_statement)
- { w }
-
-/* a statement that fits into a single rule_elem. should nests be included?
-what about statement metavariables? */
-rule_elem_statement:
- one_decl_var
- { Ast0.wrap(Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),$1)) }
-| expr TPtVirg { P.exp_stm $1 $2 }
-| TReturn eexpr TPtVirg { P.ret_exp $1 $2 $3 }
-| TReturn TPtVirg { P.ret $1 $2 }
-| TBreak TPtVirg { P.break $1 $2 }
-| TContinue TPtVirg { P.cont $1 $2 }
-| TOPar0 midzero_list(rule_elem_statement,rule_elem_statement) TCPar0
- { let (mids,code) = $2 in
- Ast0.wrap
- (Ast0.Disj(P.clt2mcode "(" $1,
- List.map (function x -> Ast0.wrap(Ast0.DOTS([x]))) code,
- mids, P.clt2mcode ")" $3)) }
-
-/* a statement on its own */
-single_statement:
- statement { $1 }
- | TOPar0 midzero_list(statement,statement) TCPar0
- /* degenerate case, elements are single statements and thus don't
- contain dots */
- { let (mids,code) = $2 in
- Ast0.wrap
- (Ast0.Disj(P.clt2mcode "(" $1,
- List.map (function x -> Ast0.wrap(Ast0.DOTS([x]))) code,
- mids, P.clt2mcode ")" $3)) }
-
-case_line:
- TDefault TDotDot fun_start
- { Ast0.wrap(Ast0.Default(P.clt2mcode "default" $1,P.clt2mcode ":" $2,$3)) }
- | TCase eexpr TDotDot fun_start
- { Ast0.wrap(Ast0.Case(P.clt2mcode "case" $1,$2,P.clt2mcode ":" $3,$4)) }
-
-/* In the following, an identifier as a type is not fully supported. Indeed,
-the language is ambiguous: what is foo * bar; */
-/* The AST DisjDecl cannot be generated because it would be ambiguous with
-a disjunction on a statement with a declaration in each branch */
-decl_var:
- t=ctype pv=TPtVirg
- { [Ast0.wrap(Ast0.TyDecl(t,P.clt2mcode ";" pv))] }
- | s=ioption(storage) t=ctype d=comma_list(d_ident) pv=TPtVirg
- { List.map
- (function (id,fn) ->
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)))
- d }
- | f=funproto { [f] }
- | s=ioption(storage) t=ctype d=d_ident q=TEq e=initialize pv=TPtVirg
- {let (id,fn) = d in
- [Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))]}
- /* type is a typedef name */
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident
- d=comma_list(d_ident) pv=TPtVirg
- { List.map
- (function (id,fn) ->
- let idtype =
- P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.UnInit(s,fn idtype,id,P.clt2mcode ";" pv)))
- d }
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident d=d_ident q=TEq
- e=initialize pv=TPtVirg
- { let (id,fn) = d in
- !Data.add_type_name (P.id2name i);
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- [Ast0.wrap(Ast0.Init(s,fn idtype,id,P.clt2mcode "=" q,e,
- P.clt2mcode ";" pv))] }
- /* function pointer type */
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv))] }
- | decl_ident TOPar eexpr_list_option TCPar TPtVirg
- { [Ast0.wrap(Ast0.MacroDecl($1,P.clt2mcode "(" $2,$3,
- P.clt2mcode ")" $4,P.clt2mcode ";" $5))] }
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))]}
- | s=Ttypedef t=ctype_full id=typedef_ident pv=TPtVirg
- { let s = P.clt2mcode "typedef" s in
- [Ast0.wrap(Ast0.Typedef(s,t,id,P.clt2mcode ";" pv))] }
-
-one_decl_var:
- t=ctype pv=TPtVirg
- { Ast0.wrap(Ast0.TyDecl(t,P.clt2mcode ";" pv)) }
- | s=ioption(storage) t=ctype d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)) }
- | f=funproto { f }
- | s=ioption(storage) t=ctype d=d_ident q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv)) }
- /* type is a typedef name */
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident
- d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.UnInit(s,fn idtype,id,P.clt2mcode ";" pv)) }
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident d=d_ident q=TEq
- e=initialize pv=TPtVirg
- { let (id,fn) = d in
- !Data.add_type_name (P.id2name i);
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.Init(s,fn idtype,id,P.clt2mcode "=" q,e,
- P.clt2mcode ";" pv)) }
- /* function pointer type */
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)) }
- | decl_ident TOPar eexpr_list_option TCPar TPtVirg
- { Ast0.wrap(Ast0.MacroDecl($1,P.clt2mcode "(" $2,$3,
- P.clt2mcode ")" $4,P.clt2mcode ";" $5)) }
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))}
-
-
-d_ident:
- ident list(array_dec)
- { ($1,
- function t ->
- List.fold_right
- (function (l,i,r) ->
- function rest ->
- Ast0.wrap
- (Ast0.Array(rest,P.clt2mcode "[" l,i,P.clt2mcode "]" r)))
- $2 t) }
-
-array_dec: l=TOCro i=option(eexpr) r=TCCro { (l,i,r) }
-
-initialize:
- eexpr
- { Ast0.wrap(Ast0.InitExpr($1)) }
- | TOBrace initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
- | TOBrace TCBrace
- { Ast0.wrap
- (Ast0.InitList(P.clt2mcode "{" $1,Ast0.wrap(Ast0.DOTS []),
- P.clt2mcode "}" $2)) }
-
-initialize2:
- /*arithexpr and not eexpr because can have ambiguity with comma*/
- /*dots and nests probably not allowed at top level, haven't looked into why*/
- arith_expr(eexpr,invalid) { Ast0.wrap(Ast0.InitExpr($1)) }
-| TOBrace initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
-| TOBrace TCBrace
- { Ast0.wrap
- (Ast0.InitList(P.clt2mcode "{" $1,Ast0.wrap(Ast0.DOTS []),
- P.clt2mcode "}" $2)) }
- /* gccext:, labeled elements */
-| TDot ident TEq initialize2
- { Ast0.wrap(Ast0.InitGccDotName(P.clt2mcode "." $1,$2,P.clt2mcode "=" $3,$4)) }
-| ident TDotDot initialize2
- { Ast0.wrap(Ast0.InitGccName($1,P.clt2mcode ":" $2,$3)) } /* in old kernel */
-| TOCro eexpr TCCro TEq initialize2
- { Ast0.wrap(Ast0.InitGccIndex(P.clt2mcode "[" $1,$2,P.clt2mcode "]" $3,
- P.clt2mcode "=" $4,$5)) }
-| TOCro eexpr TEllipsis eexpr TCCro TEq initialize2
- { Ast0.wrap(Ast0.InitGccRange(P.clt2mcode "[" $1,$2,P.clt2mcode "..." $3,
- $4,P.clt2mcode "]" $5,P.clt2mcode "=" $6,$7)) }
-
-initialize_list:
- initialize_list_start { Ast0.wrap(Ast0.DOTS($1)) }
-
-initialize_list_start:
- initialize2 TComma { [$1;Ast0.wrap(Ast0.IComma(P.clt2mcode "," $2))] }
-| initialize2 TComma initialize_list_start
- { $1::Ast0.wrap(Ast0.IComma(P.clt2mcode "," $2))::$3 }
-| d=edots_when(TEllipsis,initialize)
- r=comma_initializers(edots_when(TEllipsis,initialize))
- { (P.mkidots "..." d)::
- (List.concat(List.map (function x -> x (P.mkidots "...")) r)) }
-
-comma_initializers(dotter):
- /* empty */ { [] }
-| d=dotter r=comma_initializers2(dotter)
- { (function dot_builder -> [dot_builder d])::r }
-| i=initialize2 c=TComma r=comma_initializers(dotter)
- { (function dot_builder -> [i; Ast0.wrap(Ast0.IComma(P.clt2mcode "," c))])::
- r }
-
-comma_initializers2(dotter):
- /* empty */ { [] }
-| i=initialize2 c=TComma r=comma_initializers(dotter)
- { (function dot_builder -> [i; Ast0.wrap(Ast0.IComma(P.clt2mcode "," c))])::
- r }
-
-/* a statement that is part of a list */
-decl_statement:
- TMetaStmList
- { let (nm,pure,clt) = $1 in
- [Ast0.wrap(Ast0.MetaStmt(P.clt2mcode nm clt,pure))] }
- | decl_var
- { List.map
- (function x ->
- Ast0.wrap
- (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),x)))
- $1 }
- | statement { [$1] }
- /* this doesn't allow expressions at top level, because the parser doesn't
- know whether there is one. If there is one, this is not sequencible.
- If there is not one, then it is. It seems complicated to get around
- this at the parser level. We would have to have a check afterwards to
- allow this. One case where this would be useful is for a when. Now
- we allow a sequence of whens, so one can be on only statements and
- one can be on only expressions. */
- | TOPar0 t=midzero_list(fun_start,fun_start) TCPar0
- { let (mids,code) = t in
- if List.for_all
- (function x ->
- match Ast0.unwrap x with Ast0.DOTS([]) -> true | _ -> false)
- code
- then []
- else
- [Ast0.wrap(Ast0.Disj(P.clt2mcode "(" $1, code, mids,
- P.clt2mcode ")" $3))] }
-
-/* a statement that is part of a list */
-decl_statement_expr:
- TMetaStmList
- { let (nm,pure,clt) = $1 in
- [Ast0.wrap(Ast0.MetaStmt(P.clt2mcode nm clt,pure))] }
- | decl_var
- { List.map
- (function x ->
- Ast0.wrap
- (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),x)))
- $1 }
- | statement { [$1] }
- /* this doesn't allow expressions at top level, because the parser doesn't
- know whether there is one. If there is one, this is not sequencible.
- If there is not one, then it is. It seems complicated to get around
- this at the parser level. We would have to have a check afterwards to
- allow this. One case where this would be useful is for a when. Now
- we allow a sequence of whens, so one can be on only statements and
- one can be on only expressions. */
- | TOPar0 t=midzero_list(fun_after_stm,fun_after_dots_or) TCPar0
- { let (mids,code) = t in
- if List.for_all (function [] -> true | _ -> false) code
- then []
- else
- let dot_code =
- List.map (function x -> Ast0.wrap(Ast0.DOTS x)) code in
- [Ast0.wrap(Ast0.Disj(P.clt2mcode "(" $1, dot_code, mids,
- P.clt2mcode ")" $3))] }
-
-/*****************************************************************************/
-
-/* The following cannot contain <... ...> at the top level. This can only
-be allowed as an expression when the expression is delimited on both sides
-by expression-specific markers. In that case, the rule eexpr is used, which
-allows <... ...> anywhere. Hopefully, this will not be too much of a problem
-in practice. */
-expr: basic_expr(expr,invalid) { $1 }
-/* allows ... and nests */
-eexpr: basic_expr(eexpr,dot_expressions) { $1 }
-/* allows nests but not .... */
-dexpr: basic_expr(eexpr,nest_expressions) { $1 }
-
-top_eexpr:
- eexpr { Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))) }
-
-invalid:
- TInvalid { raise (Semantic_cocci.Semantic "not matchable") }
-
-dot_expressions:
- TEllipsis { Ast0.wrap(Ast0.Edots(P.clt2mcode "..." $1,None)) }
-| nest_expressions { $1 }
-
-/* not clear what whencode would mean, so just drop it */
-nest_expressions:
- TOEllipsis e=expr_dots(TEllipsis) c=TCEllipsis
- { Ast0.wrap(Ast0.NestExpr(P.clt2mcode "<..." $1,
- Ast0.wrap(Ast0.DOTS(e (P.mkedots "..."))),
- P.clt2mcode "...>" c, None, false)) }
-| TPOEllipsis e=expr_dots(TEllipsis) c=TPCEllipsis
- { Ast0.wrap(Ast0.NestExpr(P.clt2mcode "<+..." $1,
- Ast0.wrap(Ast0.DOTS(e (P.mkedots "..."))),
- P.clt2mcode "...+>" c, None, true)) }
-
-//whenexp: TWhen TNotEq w=eexpr TLineEnd { w }
-
-basic_expr(recurser,primary_extra):
- assign_expr(recurser,primary_extra) { $1 }
-
-assign_expr(r,pe):
- cond_expr(r,pe) { $1 }
- | unary_expr(r,pe) TAssign assign_expr_bis
- { let (op,clt) = $2 in
- Ast0.wrap(Ast0.Assignment($1,P.clt2mcode op clt,
- Ast0.set_arg_exp $3,false)) }
- | unary_expr(r,pe) TEq assign_expr_bis
- { Ast0.wrap
- (Ast0.Assignment
- ($1,P.clt2mcode Ast.SimpleAssign $2,Ast0.set_arg_exp $3,false)) }
-
-assign_expr_bis:
- cond_expr(eexpr,dot_expressions) { $1 }
- | unary_expr(eexpr,dot_expressions) TAssign assign_expr_bis
- { let (op,clt) = $2 in
- Ast0.wrap(Ast0.Assignment($1,P.clt2mcode op clt,
- Ast0.set_arg_exp $3,false)) }
- | unary_expr(eexpr,dot_expressions) TEq assign_expr_bis
- { Ast0.wrap
- (Ast0.Assignment
- ($1,P.clt2mcode Ast.SimpleAssign $2,Ast0.set_arg_exp $3,false)) }
-
-cond_expr(r,pe):
- arith_expr(r,pe) { $1 }
- | l=arith_expr(r,pe) w=TWhy t=option(eexpr) dd=TDotDot r=cond_expr(r,pe)
- { Ast0.wrap(Ast0.CondExpr (l, P.clt2mcode "?" w, t,
- P.clt2mcode ":" dd, r)) }
-
-arith_expr(r,pe):
- cast_expr(r,pe) { $1 }
- | arith_expr(r,pe) TMul arith_expr(r,pe)
- { P.arith_op Ast.Mul $1 $2 $3 }
- | arith_expr(r,pe) TDmOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.arith_op op $1 clt $3 }
- | arith_expr(r,pe) TPlus arith_expr(r,pe)
- { P.arith_op Ast.Plus $1 $2 $3 }
- | arith_expr(r,pe) TMinus arith_expr(r,pe)
- { P.arith_op Ast.Minus $1 $2 $3 }
- | arith_expr(r,pe) TShOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.arith_op op $1 clt $3 }
- | arith_expr(r,pe) TLogOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.logic_op op $1 clt $3 }
- | arith_expr(r,pe) TEqEq arith_expr(r,pe)
- { P.logic_op Ast.Eq $1 $2 $3 }
- | arith_expr(r,pe) TNotEq arith_expr(r,pe)
- { P.logic_op Ast.NotEq $1 $2 $3 }
- | arith_expr(r,pe) TAnd arith_expr(r,pe)
- { P.arith_op Ast.And $1 $2 $3 }
- | arith_expr(r,pe) TOr arith_expr(r,pe)
- { P.arith_op Ast.Or $1 $2 $3 }
- | arith_expr(r,pe) TXor arith_expr(r,pe)
- { P.arith_op Ast.Xor $1 $2 $3 }
- | arith_expr(r,pe) TAndLog arith_expr(r,pe)
- { P.logic_op Ast.AndLog $1 $2 $3 }
- | arith_expr(r,pe) TOrLog arith_expr(r,pe)
- { P.logic_op Ast.OrLog $1 $2 $3 }
-
-cast_expr(r,pe):
- unary_expr(r,pe) { $1 }
- | lp=TOPar t=ctype rp=TCPar e=cast_expr(r,pe)
- { Ast0.wrap(Ast0.Cast (P.clt2mcode "(" lp, t,
- P.clt2mcode ")" rp, e)) }
-
-unary_expr(r,pe):
- postfix_expr(r,pe) { $1 }
- | TInc unary_expr(r,pe)
- { Ast0.wrap(Ast0.Infix ($2, P.clt2mcode Ast.Inc $1)) }
- | TDec unary_expr(r,pe)
- { Ast0.wrap(Ast0.Infix ($2, P.clt2mcode Ast.Dec $1)) }
- | unary_op unary_expr(r,pe)
- { let mcode = $1 in Ast0.wrap(Ast0.Unary($2, mcode)) }
- | TBang unary_expr(r,pe)
- { let mcode = P.clt2mcode Ast.Not $1 in
- Ast0.wrap(Ast0.Unary($2, mcode)) }
- | TSizeof unary_expr(r,pe)
- { Ast0.wrap(Ast0.SizeOfExpr (P.clt2mcode "sizeof" $1, $2)) }
- | s=TSizeof lp=TOPar t=ctype rp=TCPar
- { Ast0.wrap(Ast0.SizeOfType (P.clt2mcode "sizeof" s,
- P.clt2mcode "(" lp,t,
- P.clt2mcode ")" rp)) }
-
-unary_op: TAnd { P.clt2mcode Ast.GetRef $1 }
- | TMul { P.clt2mcode Ast.DeRef $1 }
- | TPlus { P.clt2mcode Ast.UnPlus $1 }
- | TMinus { P.clt2mcode Ast.UnMinus $1 }
- | TTilde { P.clt2mcode Ast.Tilde $1 }
-
-postfix_expr(r,pe):
- primary_expr(r,pe) { $1 }
- | postfix_expr(r,pe) TOCro eexpr TCCro
- { Ast0.wrap(Ast0.ArrayAccess ($1,P.clt2mcode "[" $2,$3,
- P.clt2mcode "]" $4)) }
- | postfix_expr(r,pe) TDot ident
- { Ast0.wrap(Ast0.RecordAccess($1, P.clt2mcode "." $2, $3)) }
- | postfix_expr(r,pe) TPtrOp ident
- { Ast0.wrap(Ast0.RecordPtAccess($1, P.clt2mcode "->" $2,
- $3)) }
- | postfix_expr(r,pe) TInc
- { Ast0.wrap(Ast0.Postfix ($1, P.clt2mcode Ast.Inc $2)) }
- | postfix_expr(r,pe) TDec
- { Ast0.wrap(Ast0.Postfix ($1, P.clt2mcode Ast.Dec $2)) }
- | postfix_expr(r,pe) TOPar eexpr_list_option TCPar
- { Ast0.wrap(Ast0.FunCall($1,P.clt2mcode "(" $2,
- $3,
- P.clt2mcode ")" $4)) }
-
-primary_expr(recurser,primary_extra):
- func_ident { Ast0.wrap(Ast0.Ident($1)) }
- | TInt
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Int x) clt)) }
- | TFloat
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Float x) clt)) }
- | TString
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.String x) clt)) }
- | TChar
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Char x) clt)) }
- | TMetaConst
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.CONST,pure)) }
- | TMetaErr
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaErr(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.ANY,pure)) }
- | TMetaIdExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.ID,pure)) }
- | TMetaLocalIdExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.LocalID,pure)) }
- | TOPar eexpr TCPar
- { Ast0.wrap(Ast0.Paren(P.clt2mcode "(" $1,$2,
- P.clt2mcode ")" $3)) }
- | TOPar0 midzero_list(recurser,eexpr) TCPar0
- { let (mids,code) = $2 in
- Ast0.wrap(Ast0.DisjExpr(P.clt2mcode "(" $1,
- code, mids,
- P.clt2mcode ")" $3)) }
- | primary_extra { $1 }
-
-expr_dots(dotter):
- r=no_dot_start_end(dexpr,edots_when(dotter,eexpr)) { r }
-
-// used in NEST
-no_dot_start_end(grammar,dotter):
- g=grammar dg=list(pair(dotter,grammar))
- { function dot_builder ->
- g :: (List.concat(List.map (function (d,g) -> [dot_builder d;g]) dg)) }
-
-/*****************************************************************************/
-
-pure_ident:
- TIdent { $1 }
-
-meta_ident:
- TRuleName TDot pure_ident { (Some $1,P.id2name $3) }
-
-pure_ident_or_meta_ident:
- pure_ident { (None,P.id2name $1) }
- | meta_ident { $1 }
- | Tlist { (None,"list") }
- | TError { (None,"error") }
- | TType { (None,"type") }
- | TName { (None,"name") }
-
-pure_ident_or_meta_ident_with_not_eq(not_eq):
- i=pure_ident_or_meta_ident l=loption(not_eq) { (i,l) }
-
-not_eq:
- TNotEq i=pure_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- (* pb: constraints not stored with metavars; too lazy to search for
- them in the pattern *)
- then failwith "constraints not allowed in a generated rule file");
- [Ast0.wrap(Ast0.Id(P.id2mcode i))] }
- | TNotEq TOBrace l=comma_list(pure_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map (function i -> Ast0.wrap(Ast0.Id(P.id2mcode i))) l }
-
-not_eqe:
- TNotEq i=pure_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- [Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i))))] }
- | TNotEq TOBrace l=comma_list(pure_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map
- (function i ->
- Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i)))))
- l }
-
-not_ceq:
- TNotEq i=ident_or_const
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- [i] }
- | TNotEq TOBrace l=comma_list(ident_or_const) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- l }
-
-ident_or_const:
- i=pure_ident { Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i)))) }
- | TInt
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Int x) clt)) }
-
-not_pos:
- TNotEq i=meta_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- match i with
- (None,_) -> failwith "constraint must be an inherited variable"
- | (Some rule,name) ->
- let i = (rule,name) in
- P.check_meta(Ast.MetaPosDecl(Ast.NONE,i));
- [i] }
- | TNotEq TOBrace l=comma_list(meta_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map
- (function
- (None,_) ->
- failwith "constraint must be an inherited variable"
- | (Some rule,name) ->
- let i = (rule,name) in
- P.check_meta(Ast.MetaPosDecl(Ast.NONE,i));
- i)
- l }
-
-func_ident: pure_ident
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaId
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaFunc
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaFunc(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaLocalFunc
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaLocalFunc(P.clt2mcode nm clt,constraints,pure)) }
-
-ident: pure_ident
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaId
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-decl_ident:
- TDeclarerId
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaDeclarer
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-iter_ident:
- TIteratorId
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaIterator
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-typedef_ident:
- pure_ident
- { Ast0.wrap(Ast0.TypeName(P.id2mcode $1)) }
- | TMetaType
- { let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure)) }
-
-/*****************************************************************************/
-
-decl_list(decl):
- decl_list_start(decl)
- {let circle x =
- match Ast0.unwrap x with Ast0.Pcircles(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-decl_list_start(decl):
- one_dec(decl) { [$1] }
-| one_dec(decl) TComma decl_list_start(decl)
- { $1::Ast0.wrap(Ast0.PComma(P.clt2mcode "," $2))::$3 }
-| TEllipsis list(comma_decls(TEllipsis,decl))
- { Ast0.wrap(Ast0.Pdots(P.clt2mcode "..." $1))::
- (List.concat(List.map (function x -> x (P.mkpdots "...")) $2)) }
-
-one_dec(decl):
- decl { $1 }
-| TMetaParamList
- { let (nm,lenname,pure,clt) = $1 in
- let nm = P.clt2mcode nm clt in
- let lenname =
- match lenname with
- Some nm -> Some(P.clt2mcode nm clt)
- | None -> None in
- Ast0.wrap(Ast0.MetaParamList(nm,lenname,pure)) }
-
-comma_decls(dotter,decl):
- TComma dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.PComma(P.clt2mcode "," $1));
- dot_builder $2] }
-| TComma one_dec(decl)
- { function dot_builder ->
- [Ast0.wrap(Ast0.PComma(P.clt2mcode "," $1)); $2] }
-
-/* ---------------------------------------------------------------------- */
-
-error_words:
- TError TWords TEq TOCro cl=comma_list(dexpr) TCCro
- { [Ast0.wrap(Ast0.ERRORWORDS(cl))] }
-
-/* ---------------------------------------------------------------------- */
-/* sequences of statements and expressions */
-
-/* There are number of cases that must be considered:
-
-1. Top level:
- Dots and nests allowed at the beginning or end
- Expressions allowed at the beginning or end
- One function allowed, by itself
-2. A function body:
- Dots and nests allowed at the beginning or end
- Expressions not allowed at the beginning or end
- Functions not allowed
-3. The body of a nest:
- Dots and nests not allowed at the beginning or end
- Expressions allowed at the beginning or end
- Functions not allowed
-4. Whencode:
- Dots and nests not allowed at the beginning but allowed at the end
- Expressions allowed at the beginning or end
- Functions not allowed
-
-These are implemented by the rules minus_toplevel_sequence,
-plus_toplevel_sequence, function_body_sequence, nest_body_sequence, and
-when_body_sequence.
-*/
-/* ------------------------------------------------------------------------ */
-/* Minus top level */
-
-/* doesn't allow only ... */
-minus_start:
- fundecl { [Ast0.wrap(Ast0.DECL($1))] }
-| ctype { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Ty($1))))] }
-| top_init { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.TopInit($1))))] }
-| toplevel_seq_startne(toplevel_after_dots_init)
- { List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1 }
-
-toplevel_seq_startne(after_dots_init):
- a=stm_dots_ell b=after_dots_init { a::b }
-| a=stm_dots_nest b=after_dots_init { a::b }
-| a=stm_dots_nest { [a] }
-| expr toplevel_after_exp { (Ast0.wrap(Ast0.Exp($1)))::$2 }
-| decl_statement_expr toplevel_after_stm { $1@$2 }
-
-toplevel_seq_start(after_dots_init):
- stm_dots after_dots_init { $1::$2 }
-| expr toplevel_after_exp { (Ast0.wrap(Ast0.Exp($1)))::$2 }
-| decl_statement_expr toplevel_after_stm { $1@$2 }
-
-toplevel_after_dots_init:
- TNothing toplevel_after_exp {$2}
-| expr toplevel_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-| decl_statement_expr toplevel_after_stm {$1@$2}
-
-toplevel_after_exp:
- /* empty */ {[]}
-| stm_dots toplevel_after_dots {$1::$2}
-
-toplevel_after_dots:
- /* empty */ {[]}
-| TNothing toplevel_after_exp {$2}
-| expr toplevel_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-| decl_statement_expr toplevel_after_stm {$1@$2}
-
-toplevel_after_stm:
- /* empty */ {[]}
-| stm_dots toplevel_after_dots {$1::$2}
-| decl_statement toplevel_after_stm {$1@$2}
-
-top_init:
- TOInit initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
-
-/* ------------------------------------------------------------------------ */
-/* Plus top level */
-
-/* does allow only ... also allows multiple top-level functions */
-plus_start:
- ctype { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Ty($1))))] }
-| top_init { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.TopInit($1))))] }
-| stm_dots plus_after_dots
- { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-| expr plus_after_exp
- { (Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement_expr plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-plus_after_exp:
- /* empty */ {[]}
-| stm_dots plus_after_dots { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-
-plus_after_dots:
- /* empty */ {[]}
-| TNothing plus_after_exp {$2}
-| expr plus_after_exp
- { (Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement_expr plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-plus_after_stm:
- /* empty */ {[]}
-| stm_dots plus_after_dots { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-/* ------------------------------------------------------------------------ */
-/* Function body */
-
-fun_start:
- fun_after_stm { Ast0.wrap(Ast0.DOTS($1)) }
-
-fun_after_stm:
- /* empty */ {[]}
-| stm_dots fun_after_dots {$1::$2}
-| decl_statement fun_after_stm {$1@$2}
-
-fun_after_dots:
- /* empty */ {[]}
-| TNothing fun_after_exp {$2}
-| expr fun_after_exp {Ast0.wrap(Ast0.Exp($1))::$2}
-| decl_statement_expr fun_after_stm {$1@$2}
-
-fun_after_exp:
- stm_dots fun_after_dots {$1::$2}
-
-/* hack to allow mixing statements and expressions in an or */
-fun_after_dots_or:
- /* empty */ {[]}
-| TNothing fun_after_exp_or {$2}
-| expr fun_after_exp_or {Ast0.wrap(Ast0.Exp($1))::$2}
-| decl_statement_expr fun_after_stm {$1@$2}
-
-fun_after_exp_or:
- /* empty */ {[]}
-| stm_dots fun_after_dots {$1::$2}
-
-/* ------------------------------------------------------------------------ */
-/* Nest body */
-
-nest_start:
- nest_after_dots { Ast0.wrap(Ast0.DOTS($1)) }
-
-nest_after_dots:
- decl_statement_expr nest_after_stm {$1@$2}
-| TNothing nest_after_exp {$2}
-| expr nest_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-
-nest_after_stm:
- /* empty */ {[]}
-| stm_dots nest_after_dots {$1::$2}
-| decl_statement nest_after_stm {$1@$2}
-
-nest_after_exp:
- /* empty */ {[]}
-| stm_dots nest_after_dots {$1::$2}
-
-/* ------------------------------------------------------------------------ */
-/*Whencode*/
-
-when_start:
- expr toplevel_after_exp
- { Ast0.wrap(Ast0.DOTS((Ast0.wrap(Ast0.Exp($1)))::$2)) }
-| decl_statement toplevel_after_stm
- { Ast0.wrap(Ast0.DOTS($1@$2)) }
-
-/* ---------------------------------------------------------------------- */
-
-eexpr_list:
- eexpr_list_start
- {let circle x =
- match Ast0.unwrap x with Ast0.Ecircles(_) -> true | _ -> false in
- let star x =
- match Ast0.unwrap x with Ast0.Estars(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else
- if List.exists star $1
- then Ast0.wrap(Ast0.STARS($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-/* arg expr. may contain a type or a explist metavariable */
-aexpr:
- eexpr
- { Ast0.set_arg_exp $1 }
- | TMetaExpList
- { let (nm,lenname,pure,clt) = $1 in
- let nm = P.clt2mcode nm clt in
- let lenname =
- match lenname with
- Some nm -> Some(P.clt2mcode nm clt)
- | None -> None in
- Ast0.wrap(Ast0.MetaExprList(nm,lenname,pure)) }
- | ctype
- { Ast0.set_arg_exp(Ast0.wrap(Ast0.TypeExp($1))) }
-
-eexpr_list_start:
- aexpr { [$1] }
- | aexpr TComma eexpr_list_start
- { $1::Ast0.wrap(Ast0.EComma(P.clt2mcode "," $2))::$3 }
-
-comma_args(dotter):
- c=TComma d=dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.EComma(P.clt2mcode "," c)); dot_builder d] }
-| TComma aexpr
- { function dot_builder ->
- [Ast0.wrap(Ast0.EComma(P.clt2mcode "," $1)); $2] }
-
-eexpr_list_option: eexpr_list { $1 }
- | /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-
-/****************************************************************************/
-
-// non-empty lists - drop separator
-comma_list(elem):
- separated_nonempty_list(TComma,elem) { $1 }
-
-midzero_list(elem,aft):
- a=elem b=list(mzl(aft))
- { let (mids,code) = List.split b in (mids,(a::code)) }
-
-mzl(elem):
- a=TMid0 b=elem { (P.clt2mcode "|" a, b) }
-
-edots_when(dotter,when_grammar):
- d=dotter { (d,None) }
- | d=dotter TWhen TNotEq w=when_grammar TLineEnd { (d,Some w) }
-
-whens(when_grammar,simple_when_grammar):
- TWhen TNotEq w=when_grammar TLineEnd { [Ast0.WhenNot w] }
- | TWhen TEq w=simple_when_grammar TLineEnd { [Ast0.WhenAlways w] }
- | TWhen comma_list(any_strict) TLineEnd
- { List.map (function x -> Ast0.WhenModifier(x)) $2 }
- | TWhenTrue TNotEq e = eexpr TLineEnd { [Ast0.WhenNotTrue e] }
- | TWhenFalse TNotEq e = eexpr TLineEnd { [Ast0.WhenNotFalse e] }
-
-any_strict:
- TAny { Ast.WhenAny }
- | TStrict { Ast.WhenStrict }
- | TForall { Ast.WhenForall }
- | TExists { Ast.WhenExists }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-iso_main:
- TIsoExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.ExprTag x) e1 el }
-| TIsoArgExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.ArgExprTag x) e1 el }
-| TIsoTestExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.TestExprTag x) e1 el }
-| TIsoStatement s1=single_statement sl=list(iso(single_statement)) EOF
- { P.iso_adjust (function x -> Ast0.StmtTag x) s1 sl }
-| TIsoType t1=ctype tl=list(iso(ctype)) EOF
- { P.iso_adjust (function x -> Ast0.TypeCTag x) t1 tl }
-| TIsoTopLevel e1=nest_start el=list(iso(nest_start)) EOF
- { P.iso_adjust (function x -> Ast0.DotsStmtTag x) e1 el }
-| TIsoDeclaration d1=decl_var dl=list(iso(decl_var)) EOF
- { let check_one = function
- [x] -> x
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "only one variable per declaration in an isomorphism rule") in
- let d1 = check_one d1 in
- let dl =
- List.map
- (function
- Common.Left x -> Common.Left(check_one x)
- | Common.Right x -> Common.Right(check_one x))
- dl in
- P.iso_adjust (function x -> Ast0.DeclTag x) d1 dl }
-
-iso(term):
- TIso t=term { Common.Left t }
- | TRightIso t=term { Common.Right t }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-never_used: TPragma { () }
- | TPArob TMetaPos { () }
- | TScriptData { () }
-
-script_meta_main: py=pure_ident TShOp TRuleName TDot cocci=pure_ident TMPtVirg
- { (P.id2name py, ($3, P.id2name cocci)) }
+++ /dev/null
-/*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*/
-
-
-%{
-
-(* Not clear how to allow function declarations to specify a return type
-and how to allow both to be specified as static, because they are in
-different rules. The rules seem to have to be combined, which would allow
-functions to be declared as local variables *)
-
-(* Not clear how to let a function have a parameter of type void. At the
-moment, void is allowed to be the type of a variable, which is wrong, and a
-parameter needs both a type and an identifier *)
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module P = Parse_aux
-%}
-
-%token EOF
-
-%token TIdentifier TExpression TStatement TFunction TLocal TType TParameter
-%token TIdExpression TInitialiser
-%token Tlist TFresh TConstant TError TWords TWhy0 TPlus0 TBang0
-%token TPure TContext TGenerated
-%token TTypedef TDeclarer TIterator TName TPosition TPosAny
-%token TUsing TDisable TExtends TDepends TOn TEver TNever TExists TForall
-%token TScript TReverse TNothing
-%token<string> TRuleName
-
-%token<Data.clt> Tchar Tshort Tint Tdouble Tfloat Tlong
-%token<Data.clt> Tvoid Tstruct Tunion Tenum
-%token<Data.clt> Tunsigned Tsigned
-
-%token<Data.clt> Tstatic Tauto Tregister Textern Tinline Ttypedef
-%token<Data.clt> Tconst Tvolatile
-%token<string * Data.clt> Tattr
-
-%token <Data.clt> TIf TElse TWhile TFor TDo TSwitch TCase TDefault TReturn
-%token <Data.clt> TBreak TContinue TGoto TSizeof TFunDecl
-%token <string * Data.clt> TIdent TTypeId TDeclarerId TIteratorId
-
-%token <Parse_aux.idinfo> TMetaId TMetaFunc TMetaLocalFunc
-%token <Parse_aux.idinfo> TMetaIterator TMetaDeclarer
-%token <Parse_aux.expinfo> TMetaErr
-%token <Parse_aux.info> TMetaParam TMetaStm TMetaStmList TMetaType
-%token <Parse_aux.info> TMetaInit
-%token <Parse_aux.list_info> TMetaParamList TMetaExpList
-%token <Parse_aux.typed_info> TMetaExp TMetaIdExp TMetaLocalIdExp TMetaConst
-%token <Parse_aux.pos_info> TMetaPos
-
-%token TArob TArobArob TPArob
-%token <string> TScriptData
-
-%token <Data.clt> TEllipsis TOEllipsis TCEllipsis TPOEllipsis TPCEllipsis
-%token <Data.clt> TWhen TWhenTrue TWhenFalse TAny TStrict TLineEnd
-
-%token <Data.clt> TWhy TDotDot TBang TOPar TOPar0
-%token <Data.clt> TMid0 TCPar TCPar0
-
-%token <string> TPragma TPathIsoFile
-%token <string * Data.clt> TIncludeL TIncludeNL
-%token <Data.clt * token> TDefine
-%token <Data.clt * token * int> TDefineParam
-%token <string * Data.clt> TMinusFile TPlusFile
-
-%token <Data.clt> TInc TDec
-
-%token <string * Data.clt> TString TChar TFloat TInt
-
-%token <Data.clt> TOrLog
-%token <Data.clt> TAndLog
-%token <Data.clt> TOr
-%token <Data.clt> TXor
-%token <Data.clt> TAnd
-%token <Data.clt> TEqEq TNotEq
-%token <Ast_cocci.logicalOp * Data.clt> TLogOp /* TInf TSup TInfEq TSupEq */
-%token <Ast_cocci.arithOp * Data.clt> TShOp /* TShl TShr */
-%token <Ast_cocci.arithOp * Data.clt> TDmOp /* TDiv TMod */
-%token <Data.clt> TPlus TMinus
-%token <Data.clt> TMul TTilde
-
-%token <Data.clt> TOBrace TCBrace TOInit
-%token <Data.clt> TOCro TCCro
-
-%token <Data.clt> TPtrOp
-
-%token TMPtVirg
-%token <Data.clt> TEq TDot TComma TPtVirg
-%token <Ast_cocci.assignOp * Data.clt> TAssign
-
-%token TIso TRightIso TIsoExpression TIsoStatement TIsoDeclaration TIsoType
-%token TIsoTopLevel TIsoArgExpression TIsoTestExpression
-
-%token TInvalid
-
-/* operator precedence */
-%nonassoc TIf
-%nonassoc TElse
-
-%left TOrLog
-%left TAndLog
-%left TOr
-%left TXor
-%left TAnd
-%left TEqEq TNotEq
-%left TLogOp /* TInf TSup TInfEq TSupEq */
-%left TShOp /* TShl TShr */
-%left TPlus TMinus
-%left TMul TDmOp /* TDiv TMod */
-
-%start reinit
-%type <unit> reinit
-
-%start minus_main
-%type <Ast0_cocci.rule> minus_main
-
-%start minus_exp_main
-%type <Ast0_cocci.rule> minus_exp_main
-
-%start plus_main
-%type <Ast0_cocci.rule> plus_main
-
-%start plus_exp_main
-%type <Ast0_cocci.rule> plus_exp_main
-
-%start include_main
-%type <(string,string) Common.either list> include_main
-
-%start iso_rule_name
-%type <Ast_cocci.rulename>
-iso_rule_name
-
-%start rule_name
-%type <Ast_cocci.rulename>
-rule_name
-
-%start meta_main
-%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> meta_main
-
-%start <string * (string * string)> script_meta_main
-
-%start iso_main
-%type <Ast0_cocci.anything list list> iso_main
-
-%start iso_meta_main
-%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> iso_meta_main
-
-%start never_used
-%type <unit> never_used
-
-%%
-
-reinit: { }
-minus_main: minus_body EOF { $1 } | m=minus_body TArobArob { m }
-| m=minus_body TArob { m }
-plus_main: plus_body EOF { $1 } | p=plus_body TArobArob { p }
-| p=plus_body TArob { p }
-minus_exp_main: minus_exp_body EOF { $1 } | m=minus_exp_body TArobArob { m }
-| m=minus_exp_body TArob { m }
-plus_exp_main: plus_exp_body EOF { $1 } | p=plus_exp_body TArobArob { p }
-| p=plus_exp_body TArob { p }
-meta_main: m=metadec { m (!Ast0.rule_name) }
-iso_meta_main: m=metadec { m "" }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-pure:
- TPure { Ast0.Pure }
-| TContext { Ast0.Context }
-| TPure TContext { Ast0.PureContext }
-| TContext TPure { Ast0.PureContext }
-| /* empty */ { Ast0.Impure }
-
-iso_rule_name:
- nm=pure_ident TArob { P.make_iso_rule_name_result (P.id2name nm) }
-
-rule_name:
- nm=ioption(pure_ident) extends d=depends i=loption(choose_iso)
- a=loption(disable) e=exists ee=is_expression TArob
- { P.make_cocci_rule_name_result nm d i a e ee }
- | TGenerated extends d=depends i=loption(choose_iso)
- a=loption(disable) e=exists ee=is_expression TArob
- /* these rules have no name as a cheap way to ensure that no normal
- rule inherits their metavariables or depends on them */
- { P.make_generated_rule_name_result None d i a e ee }
- | TScript TDotDot lang=pure_ident d=depends TArob
- { P.make_script_rule_name_result lang d }
-
-extends:
- /* empty */ { () }
-| TExtends parent=TRuleName
- { !Data.install_bindings (parent) }
-
-depends:
- /* empty */ { Ast.NoDep }
-| TDepends TOn parents=dep { parents }
-
-dep:
- pnrule { $1 }
-| dep TAndLog dep { Ast.AndDep($1, $3) }
-| dep TOrLog dep { Ast.OrDep ($1, $3) }
-
-pnrule:
- TRuleName { Ast.Dep $1 }
-| TBang TRuleName { Ast.AntiDep $2 }
-| TEver TRuleName { Ast.EverDep $2 }
-| TNever TRuleName { Ast.NeverDep $2 }
-| TOPar dep TCPar { $2 }
-
-choose_iso:
- TUsing separated_nonempty_list(TComma,TString) { List.map P.id2name $2 }
-
-disable:
- TDisable separated_nonempty_list(TComma,pure_ident) { List.map P.id2name $2 }
-
-exists:
- TExists { Ast.Exists }
-| TForall { Ast.Forall }
-| TReverse TForall { Ast.ReverseForall }
-| { Ast.Undetermined }
-
-is_expression: // for more flexible parsing of top level expressions
- { false }
-| TExpression { true }
-
-include_main:
- list(incl) TArob { $1 }
-| list(incl) TArobArob { $1 }
-
-incl:
- TUsing TString { Common.Left(P.id2name $2) }
-| TUsing TPathIsoFile { Common.Right $2 }
-
-metadec:
- ar=arity ispure=pure
- kindfn=metakind ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_metadec ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_eq)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic_expi
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_eqe)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic_expe
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_ceq)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity TPosition a=option(TPosAny)
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_pos)) TMPtVirg
- (* pb: position variables can't be inherited from normal rules, and then
- there is no way to inherit from a generated rule, so there is no point
- to have a position variable *)
- { (if !Data.in_generating
- then failwith "position variables not allowed in a generated rule file");
- let kindfn arity name pure check_meta constraints =
- let tok = check_meta(Ast.MetaPosDecl(arity,name)) in
- let any = match a with None -> Ast.PER | Some _ -> Ast.ALL in
- !Data.add_pos_meta name constraints any; tok in
- P.create_metadec_ne ar false kindfn ids }
-| ar=arity ispure=pure
- TParameter Tlist TOCro id=pure_ident_or_meta_ident TCCro
- ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_len_metadec ar ispure
- (fun lenname arity name pure check_meta ->
- let tok =
- check_meta(Ast.MetaParamListDecl(arity,name,Some lenname)) in
- !Data.add_paramlist_meta name (Some lenname) pure; tok)
- id ids }
-| ar=arity ispure=pure
- TExpression Tlist TOCro id=pure_ident_or_meta_ident TCCro
- ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_len_metadec ar ispure
- (fun lenname arity name pure check_meta ->
- let tok =
- check_meta(Ast.MetaExpListDecl(arity,name,Some lenname)) in
- !Data.add_explist_meta name (Some lenname) pure; tok)
- id ids }
-
-%inline metakind:
- TFresh TIdentifier
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaFreshIdDecl(arity,name)) in
- !Data.add_id_meta name [] pure; tok) }
-| TParameter
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaParamDecl(arity,name)) in
- !Data.add_param_meta name pure; tok) }
-| TParameter Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaParamListDecl(arity,name,None)) in
- !Data.add_paramlist_meta name None pure; tok) }
-| TExpression Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaExpListDecl(arity,name,None)) in
- !Data.add_explist_meta name None pure; tok) }
-| TType
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaTypeDecl(arity,name)) in
- !Data.add_type_meta name pure; tok) }
-| TInitialiser
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaInitDecl(arity,name)) in
- !Data.add_init_meta name pure; tok) }
-| TStatement
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaStmDecl(arity,name)) in
- !Data.add_stm_meta name pure; tok) }
-| TStatement Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaStmListDecl(arity,name)) in
- !Data.add_stmlist_meta name pure; tok) }
-| TTypedef
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_type_name name; [])
- else raise (Semantic_cocci.Semantic "bad typedef")) }
-| TDeclarer TName
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_declarer_name name; [])
- else raise (Semantic_cocci.Semantic "bad declarer")) }
-| TIterator TName
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_iterator_name name; [])
- else raise (Semantic_cocci.Semantic "bad iterator")) }
-
-
-%inline metakind_atomic:
- TIdentifier
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaIdDecl(arity,name)) in
- !Data.add_id_meta name constraints pure; tok) }
-| TFunction
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaFuncDecl(arity,name)) in
- !Data.add_func_meta name constraints pure; tok) }
-| TLocal TFunction
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaLocalFuncDecl(arity,name)) in
- !Data.add_local_func_meta name constraints pure;
- tok) }
-| TDeclarer
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaDeclarerDecl(arity,name)) in
- !Data.add_declarer_meta name constraints pure; tok) }
-| TIterator
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaIteratorDecl(arity,name)) in
- !Data.add_iterator_meta name constraints pure; tok) }
-
-%inline metakind_atomic_expi:
- TError
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaErrDecl(arity,name)) in
- !Data.add_err_meta name constraints pure; tok) }
-| l=option(TLocal) TIdExpression ty=ioption(meta_exp_type)
- { (fun arity name pure check_meta constraints ->
- match l with
- None ->
- !Data.add_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaIdExpDecl(arity,name,ty))
- | Some _ ->
- !Data.add_local_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaLocalIdExpDecl(arity,name,ty))) }
-| l=option(TLocal) TIdExpression m=nonempty_list(TMul)
- { (fun arity name pure check_meta constraints ->
- let ty = Some [P.ty_pointerify Type_cocci.Unknown m] in
- match l with
- None ->
- !Data.add_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaIdExpDecl(arity,name,ty))
- | Some _ ->
- !Data.add_local_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaLocalIdExpDecl(arity,name,ty))) }
-| TExpression m=nonempty_list(TMul)
- { (fun arity name pure check_meta constraints ->
- let ty = Some [P.ty_pointerify Type_cocci.Unknown m] in
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-| vl=meta_exp_type TOCro TCCro
- { (fun arity name pure check_meta constraints ->
- let ty = Some (List.map (function x -> Type_cocci.Array x) vl) in
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-| TConstant ty=ioption(meta_exp_type)
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaConstDecl(arity,name,ty)) in
- !Data.add_const_meta ty name constraints pure; tok) }
-
-%inline metakind_atomic_expe:
- TExpression
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaExpDecl(arity,name,None)) in
- !Data.add_exp_meta None name constraints pure; tok) }
-| vl=meta_exp_type // no error if use $1 but doesn't type check
- { (fun arity name pure check_meta constraints ->
- let ty = Some vl in
- List.iter
- (function c ->
- match Ast0.unwrap c with
- Ast0.Constant(_) ->
- if not
- (List.exists
- (function
- Type_cocci.BaseType(Type_cocci.IntType) -> true
- | Type_cocci.BaseType(Type_cocci.ShortType) -> true
- | Type_cocci.BaseType(Type_cocci.LongType) -> true
- | _ -> false)
- vl)
- then failwith "metavariable with int constraint must be an int"
- | _ -> ())
- constraints;
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-
-
-meta_exp_type:
- t=ctype
- { [Ast0_cocci.ast0_type_to_type t] }
-| TOBrace t=comma_list(ctype) TCBrace m=list(TMul)
- { List.map
- (function x -> P.ty_pointerify (Ast0_cocci.ast0_type_to_type x) m)
- t }
-
-arity: TBang0 { Ast.UNIQUE }
- | TWhy0 { Ast.OPT }
- | TPlus0 { Ast.MULTI }
- | /* empty */ { Ast.NONE }
-
-generic_ctype_full:
- q=ctype_qualif_opt ty=Tchar
- { q (Ast0.wrap(Ast0.BaseType(Ast.CharType,[P.clt2mcode "char" ty]))) }
- | q=ctype_qualif_opt ty=Tshort
- { q (Ast0.wrap(Ast0.BaseType(Ast.ShortType,[P.clt2mcode "short" ty])))}
- | q=ctype_qualif_opt ty=Tint
- { q (Ast0.wrap(Ast0.BaseType(Ast.IntType,[P.clt2mcode "int" ty]))) }
- | t=Tdouble
- { Ast0.wrap(Ast0.BaseType(Ast.DoubleType,[P.clt2mcode "double" t])) }
- | t=Tfloat
- { Ast0.wrap(Ast0.BaseType(Ast.FloatType,[P.clt2mcode "float" t])) }
- | q=ctype_qualif_opt ty=Tlong
- { q (Ast0.wrap(Ast0.BaseType(Ast.LongType,[P.clt2mcode "long" ty]))) }
- | q=ctype_qualif_opt ty=Tlong ty1=Tlong
- { q (Ast0.wrap
- (Ast0.BaseType
- (Ast.LongLongType,
- [P.clt2mcode "long" ty;P.clt2mcode "long" ty1]))) }
- | s=Tenum i=ident
- { Ast0.wrap(Ast0.EnumName(P.clt2mcode "enum" s, i)) }
- | s=struct_or_union i=ident
- { Ast0.wrap(Ast0.StructUnionName(s, Some i)) }
- | s=struct_or_union i=ioption(ident)
- l=TOBrace d=struct_decl_list r=TCBrace
- { (if i = None && !Data.in_iso
- then failwith "structures must be named in the iso file");
- Ast0.wrap(Ast0.StructUnionDef(Ast0.wrap(Ast0.StructUnionName(s, i)),
- P.clt2mcode "{" l,
- d, P.clt2mcode "}" r)) }
- | s=TMetaType l=TOBrace d=struct_decl_list r=TCBrace
- { let (nm,pure,clt) = s in
- let ty =
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure)) in
- Ast0.wrap
- (Ast0.StructUnionDef(ty,P.clt2mcode "{" l,d,P.clt2mcode "}" r)) }
- | r=TRuleName TDot p=TIdent
- { let nm = (r,P.id2name p) in
- (* this is only possible when we are in a metavar decl. Otherwise,
- it will be represented already as a MetaType *)
- let _ = P.check_meta(Ast.MetaTypeDecl(Ast.NONE,nm)) in
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm (P.id2clt p),
- Ast0.Impure (*will be ignored*))) }
- | p=TTypeId
- { Ast0.wrap(Ast0.TypeName(P.id2mcode p)) }
- | q=ctype_qualif_opt p=TMetaType
- { let (nm,pure,clt) = p in
- q (Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure))) }
-
-generic_ctype:
- q=ctype_qualif { q None }
- | generic_ctype_full { $1 }
-
-struct_or_union:
- s=Tstruct { P.clt2mcode Ast.Struct s }
- | u=Tunion { P.clt2mcode Ast.Union u }
-
-struct_decl:
- TNothing { [] }
- | t=ctype d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- [Ast0.wrap(Ast0.UnInit(None,fn t,id,P.clt2mcode ";" pv))] }
- | t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.UnInit(None,fn t,id,P.clt2mcode ";" pv))] }
- | cv=ioption(const_vol) i=pure_ident d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- [Ast0.wrap(Ast0.UnInit(None,fn idtype,id,P.clt2mcode ";" pv))] }
-
-struct_decl_list:
- struct_decl_list_start { Ast0.wrap(Ast0.DOTS($1)) }
-
-struct_decl_list_start:
- struct_decl { $1 }
-| struct_decl struct_decl_list_start { $1@$2 }
-| d=edots_when(TEllipsis,struct_decl) r=continue_struct_decl_list
- { (P.mkddots "..." d)::r }
-
-continue_struct_decl_list:
- /* empty */ { [] }
-| struct_decl struct_decl_list_start { $1@$2 }
-| struct_decl { $1 }
-
-ctype:
- cv=ioption(const_vol) ty=generic_ctype m=list(TMul)
- { P.pointerify (P.make_cv cv ty) m }
- | cv=ioption(const_vol) t=Tvoid m=nonempty_list(TMul)
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- P.pointerify (P.make_cv cv ty) m }
- | lp=TOPar0 t=midzero_list(ctype,ctype) rp=TCPar0
- /* more hacks */
- { let (mids,code) = t in
- Ast0.wrap
- (Ast0.DisjType(P.clt2mcode "(" lp,code,mids, P.clt2mcode ")" rp)) }
-
-ctype_full:
- cv=ioption(const_vol) ty=generic_ctype_full m=list(TMul)
- { P.pointerify (P.make_cv cv ty) m }
- | cv=ioption(const_vol) t=Tvoid m=nonempty_list(TMul)
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- P.pointerify (P.make_cv cv ty) m }
- | lp=TOPar0 t=midzero_list(ctype,ctype) rp=TCPar0
- /* more hacks */
- { let (mids,code) = t in
- Ast0.wrap
- (Ast0.DisjType(P.clt2mcode "(" lp,code,mids, P.clt2mcode ")" rp)) }
-
-
-fn_ctype: // allows metavariables
- ty=generic_ctype m=list(TMul) { P.pointerify ty m }
- | t=Tvoid m=list(TMul)
- { P.pointerify
- (Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])))
- m }
-
-%inline ctype_qualif:
- r=Tunsigned
- { function x -> Ast0.wrap(Ast0.Signed(P.clt2mcode Ast.Unsigned r,x)) }
-| r=Tsigned
- { function x -> Ast0.wrap(Ast0.Signed(P.clt2mcode Ast.Signed r,x)) }
-
-%inline ctype_qualif_opt:
- s=ctype_qualif { function x -> s (Some x) }
-| /* empty */ { function x -> x }
-
-/*****************************************************************************/
-
-/* have to inline everything to avoid conflicts? switch to proper
-declarations, statements, and expressions for the subterms */
-
-minus_body:
- f=loption(filespec)
- b=loption(minus_start)
- ew=loption(error_words)
- { match f@b@ew with
- [] -> raise (Semantic_cocci.Semantic "minus slice can't be empty")
- | code -> Top_level.top_level code }
-
-plus_body:
- f=loption(filespec)
- b=loption(plus_start)
- ew=loption(error_words)
- { Top_level.top_level (f@b@ew) }
-
-minus_exp_body:
- f=loption(filespec)
- b=top_eexpr
- ew=loption(error_words)
- { match f@[b]@ew with
- [] -> raise (Semantic_cocci.Semantic "minus slice can't be empty")
- | code -> Top_level.top_level code }
-
-plus_exp_body:
- f=loption(filespec)
- b=top_eexpr
- ew=loption(error_words)
- { Top_level.top_level (f@[b]@ew) }
-
-filespec:
- TMinusFile TPlusFile
- { [Ast0.wrap
- (Ast0.FILEINFO(P.id2mcode $1,
- P.id2mcode $2))] }
-
-includes:
- TIncludeL
- { Ast0.wrap
- (Ast0.Include(P.clt2mcode "#include" (P.drop_aft (P.id2clt $1)),
- let (arity,ln,lln,offset,col,strbef,straft,pos) =
- P.id2clt $1 in
- let clt =
- (arity,ln,lln,offset,0,strbef,straft,pos) in
- P.clt2mcode
- (Ast.Local (Parse_aux.str2inc (P.id2name $1)))
- (P.drop_bef clt))) }
-| TIncludeNL
- { Ast0.wrap
- (Ast0.Include(P.clt2mcode "#include" (P.drop_aft (P.id2clt $1)),
- let (arity,ln,lln,offset,col,strbef,straft,pos) =
- P.id2clt $1 in
- let clt =
- (arity,ln,lln,offset,0,strbef,straft,pos) in
- P.clt2mcode
- (Ast.NonLocal (Parse_aux.str2inc (P.id2name $1)))
- (P.drop_bef clt))) }
-| d=defineop t=ctype TLineEnd
- { let ty = Ast0.wrap(Ast0.TopExp(Ast0.wrap(Ast0.TypeExp(t)))) in
- d (Ast0.wrap(Ast0.DOTS([ty]))) }
-| defineop b=toplevel_seq_start(toplevel_after_dots) TLineEnd
- { let body =
- match b with
- [e] ->
- (match Ast0.unwrap e with
- Ast0.Exp(e1) ->
- [Ast0.rewrap e (Ast0.TopExp(Ast0.set_arg_exp (e1)))]
- | _ -> b)
- | _ -> b in
- $1 (Ast0.wrap(Ast0.DOTS(body))) }
-
-defineop:
- TDefine
- { let (clt,ident) = $1 in
- function body ->
- Ast0.wrap
- (Ast0.Define
- (P.clt2mcode "#define" clt,
- (match ident with
- TMetaId((nm,constraints,pure,clt)) ->
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure))
- | TIdent(nm_pure) ->
- Ast0.wrap(Ast0.Id(P.id2mcode nm_pure))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "unexpected name for a #define")),
- Ast0.wrap Ast0.NoParams,
- body)) }
-| TDefineParam define_param_list_option TCPar
- { let (clt,ident,parenoff) = $1 in
- let (arity,line,lline,offset,col,strbef,straft,pos) = clt in
- let lp =
- P.clt2mcode "(" (arity,line,lline,parenoff,0,[],[],Ast0.NoMetaPos) in
- function body ->
- Ast0.wrap
- (Ast0.Define
- (P.clt2mcode "#define" clt,
- (match ident with
- TMetaId((nm,constraints,pure,clt)) ->
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure))
- | TIdent(nm_pure) ->
- Ast0.wrap(Ast0.Id(P.id2mcode nm_pure))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "unexpected name for a #define")),
- Ast0.wrap (Ast0.DParams (lp,$2,P.clt2mcode ")" $3)),body)) }
-
-/* ---------------------------------------------------------------------- */
-
-define_param_list: define_param_list_start
- {let circle x =
- match Ast0.unwrap x with Ast0.DPcircles(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-define_param_list_start:
- ident { [Ast0.wrap(Ast0.DParam $1)] }
- | ident TComma define_param_list_start
- { Ast0.wrap(Ast0.DParam $1)::
- Ast0.wrap(Ast0.DPComma(P.clt2mcode "," $2))::$3 }
- | d=TEllipsis r=list(dp_comma_args(TEllipsis))
- { (P.mkdpdots "..." d)::
- (List.concat (List.map (function x -> x (P.mkdpdots "...")) r)) }
-
-dp_comma_args(dotter):
- c=TComma d=dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.DPComma(P.clt2mcode "," c)); dot_builder d] }
-| TComma ident
- { function dot_builder ->
- [Ast0.wrap(Ast0.DPComma(P.clt2mcode "," $1));
- Ast0.wrap(Ast0.DParam $2)] }
-
-define_param_list_option: define_param_list { $1 }
- | /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-
-/*****************************************************************************/
-
-funproto:
- s=ioption(storage) t=ctype
- id=func_ident lp=TOPar d=decl_list(name_opt_decl) rp=TCPar pt=TPtVirg
- { Ast0.wrap
- (Ast0.UnInit
- (s,
- Ast0.wrap
- (Ast0.FunctionType(Some t,
- P.clt2mcode "(" lp, d, P.clt2mcode ")" rp)),
- id, P.clt2mcode ";" pt)) }
-| s=ioption(storage) t=Tvoid
- id=func_ident lp=TOPar d=decl_list(name_opt_decl) rp=TCPar pt=TPtVirg
- { let t = Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- Ast0.wrap
- (Ast0.UnInit
- (s,
- Ast0.wrap
- (Ast0.FunctionType(Some t,
- P.clt2mcode "(" lp, d, P.clt2mcode ")" rp)),
- id, P.clt2mcode ";" pt)) }
-
-
-fundecl:
- f=fninfo
- TFunDecl i=func_ident lp=TOPar d=decl_list(decl) rp=TCPar
- lb=TOBrace b=fun_start rb=TCBrace
- { Ast0.wrap(Ast0.FunDecl((Ast0.default_info(),Ast0.context_befaft()),
- f, i,
- P.clt2mcode "(" lp, d,
- P.clt2mcode ")" rp,
- P.clt2mcode "{" lb, b,
- P.clt2mcode "}" rb)) }
-
-fninfo:
- /* empty */ { [] }
- | storage fninfo
- { try
- let _ =
- List.find (function Ast0.FStorage(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate storage")
- with Not_found -> (Ast0.FStorage($1))::$2 }
- | t=fn_ctype r=fninfo_nt { (Ast0.FType(t))::r }
- | Tinline fninfo
- { try
- let _ = List.find (function Ast0.FInline(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate inline")
- with Not_found -> (Ast0.FInline(P.clt2mcode "inline" $1))::$2 }
- | Tattr fninfo
- { try
- let _ = List.find (function Ast0.FAttr(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "multiple attributes")
- with Not_found -> (Ast0.FAttr(P.id2mcode $1))::$2 }
-
-fninfo_nt:
- /* empty */ { [] }
- | storage fninfo_nt
- { try
- let _ =
- List.find (function Ast0.FStorage(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate storage")
- with Not_found -> (Ast0.FStorage($1))::$2 }
- | Tinline fninfo_nt
- { try
- let _ = List.find (function Ast0.FInline(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate inline")
- with Not_found -> (Ast0.FInline(P.clt2mcode "inline" $1))::$2 }
- | Tattr fninfo_nt
- { try
- let _ = List.find (function Ast0.FAttr(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate init")
- with Not_found -> (Ast0.FAttr(P.id2mcode $1))::$2 }
-
-storage:
- s=Tstatic { P.clt2mcode Ast.Static s }
- | s=Tauto { P.clt2mcode Ast.Auto s }
- | s=Tregister { P.clt2mcode Ast.Register s }
- | s=Textern { P.clt2mcode Ast.Extern s }
-
-decl: t=ctype i=ident
- { Ast0.wrap(Ast0.Param(t, Some i)) }
- | t=fn_ctype lp=TOPar s=TMul i=ident rp=TCPar
- lp1=TOPar d=decl_list(name_opt_decl) rp1=TCPar
- { let fnptr =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp,P.clt2mcode "*" s,P.clt2mcode ")" rp,
- P.clt2mcode "(" lp1,d,P.clt2mcode ")" rp1)) in
- Ast0.wrap(Ast0.Param(fnptr, Some i)) }
- | t=Tvoid
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- Ast0.wrap(Ast0.VoidParam(ty)) }
- | TMetaParam
- { let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaParam(P.clt2mcode nm clt,pure)) }
-
-name_opt_decl:
- decl { $1 }
- | t=ctype { Ast0.wrap(Ast0.Param(t, None)) }
- | t=fn_ctype lp=TOPar s=TMul rp=TCPar
- lp1=TOPar d=decl_list(name_opt_decl) rp1=TCPar
- { let fnptr =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp,P.clt2mcode "*" s,P.clt2mcode ")" rp,
- P.clt2mcode "(" lp1,d,P.clt2mcode ")" rp1)) in
- Ast0.wrap(Ast0.Param(fnptr, None)) }
-
-const_vol:
- Tconst { P.clt2mcode Ast.Const $1 }
- | Tvolatile { P.clt2mcode Ast.Volatile $1 }
-
-/*****************************************************************************/
-
-statement:
- includes { $1 } /* shouldn't be allowed to be a single_statement... */
-| TMetaStm
- { P.meta_stm $1 }
-| expr TPtVirg
- { P.exp_stm $1 $2 }
-| TIf TOPar eexpr TCPar single_statement %prec TIf
- { P.ifthen $1 $2 $3 $4 $5 }
-| TIf TOPar eexpr TCPar single_statement TElse single_statement
- { P.ifthenelse $1 $2 $3 $4 $5 $6 $7 }
-| TFor TOPar option(eexpr) TPtVirg option(eexpr) TPtVirg
- option(eexpr) TCPar single_statement
- { P.forloop $1 $2 $3 $4 $5 $6 $7 $8 $9 }
-| TWhile TOPar eexpr TCPar single_statement
- { P.whileloop $1 $2 $3 $4 $5 }
-| TDo single_statement TWhile TOPar eexpr TCPar TPtVirg
- { P.doloop $1 $2 $3 $4 $5 $6 $7 }
-| iter_ident TOPar eexpr_list_option TCPar single_statement
- { P.iterator $1 $2 $3 $4 $5 }
-| TSwitch TOPar eexpr TCPar TOBrace list(case_line) TCBrace
- { P.switch $1 $2 $3 $4 $5 $6 $7 }
-| TReturn eexpr TPtVirg { P.ret_exp $1 $2 $3 }
-| TReturn TPtVirg { P.ret $1 $2 }
-| TBreak TPtVirg { P.break $1 $2 }
-| TContinue TPtVirg { P.cont $1 $2 }
-| ident TDotDot { P.label $1 $2 }
-| TGoto ident TPtVirg { P.goto $1 $2 $3 }
-| TOBrace fun_start TCBrace
- { P.seq $1 $2 $3 }
-
-stm_dots:
- TEllipsis w=list(whenppdecs)
- { Ast0.wrap(Ast0.Dots(P.clt2mcode "..." $1, List.concat w)) }
-| TOEllipsis w=list(whenppdecs) b=nest_start c=TCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<..." $1, b,
- P.clt2mcode "...>" c, List.concat w, false)) }
-| TPOEllipsis w=list(whenppdecs) b=nest_start c=TPCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<+..." $1, b,
- P.clt2mcode "...+>" c, List.concat w, true)) }
-
-%inline stm_dots_ell:
- a=TEllipsis w=list(whenppdecs)
- { Ast0.wrap(Ast0.Dots(P.clt2mcode "..." a, List.concat w)) }
-
-%inline stm_dots_nest:
- a=TOEllipsis w=list(whenppdecs) b=nest_start c=TCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<..." a, b,
- P.clt2mcode "...>" c, List.concat w, false)) }
-| a=TPOEllipsis w=list(whenppdecs) b=nest_start c=TPCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<+..." a, b,
- P.clt2mcode "...+>" c, List.concat w, true)) }
-
-whenppdecs: w=whens(when_start,rule_elem_statement)
- { w }
-
-/* a statement that fits into a single rule_elem. should nests be included?
-what about statement metavariables? */
-rule_elem_statement:
- one_decl_var
- { Ast0.wrap(Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),$1)) }
-| expr TPtVirg { P.exp_stm $1 $2 }
-| TReturn eexpr TPtVirg { P.ret_exp $1 $2 $3 }
-| TReturn TPtVirg { P.ret $1 $2 }
-| TBreak TPtVirg { P.break $1 $2 }
-| TContinue TPtVirg { P.cont $1 $2 }
-| TOPar0 midzero_list(rule_elem_statement,rule_elem_statement) TCPar0
- { let (mids,code) = $2 in
- Ast0.wrap
- (Ast0.Disj(P.clt2mcode "(" $1,
- List.map (function x -> Ast0.wrap(Ast0.DOTS([x]))) code,
- mids, P.clt2mcode ")" $3)) }
-
-/* a statement on its own */
-single_statement:
- statement { $1 }
- | TOPar0 midzero_list(statement,statement) TCPar0
- /* degenerate case, elements are single statements and thus don't
- contain dots */
- { let (mids,code) = $2 in
- Ast0.wrap
- (Ast0.Disj(P.clt2mcode "(" $1,
- List.map (function x -> Ast0.wrap(Ast0.DOTS([x]))) code,
- mids, P.clt2mcode ")" $3)) }
-
-case_line:
- TDefault TDotDot fun_start
- { Ast0.wrap(Ast0.Default(P.clt2mcode "default" $1,P.clt2mcode ":" $2,$3)) }
- | TCase eexpr TDotDot fun_start
- { Ast0.wrap(Ast0.Case(P.clt2mcode "case" $1,$2,P.clt2mcode ":" $3,$4)) }
-
-/* In the following, an identifier as a type is not fully supported. Indeed,
-the language is ambiguous: what is foo * bar; */
-/* The AST DisjDecl cannot be generated because it would be ambiguous with
-a disjunction on a statement with a declaration in each branch */
-decl_var:
- t=ctype pv=TPtVirg
- { [Ast0.wrap(Ast0.TyDecl(t,P.clt2mcode ";" pv))] }
- | s=ioption(storage) t=ctype d=comma_list(d_ident) pv=TPtVirg
- { List.map
- (function (id,fn) ->
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)))
- d }
- | f=funproto { [f] }
- | s=ioption(storage) t=ctype d=d_ident q=TEq e=initialize pv=TPtVirg
- {let (id,fn) = d in
- [Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))]}
- /* type is a typedef name */
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident
- d=comma_list(d_ident) pv=TPtVirg
- { List.map
- (function (id,fn) ->
- let idtype =
- P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.UnInit(s,fn idtype,id,P.clt2mcode ";" pv)))
- d }
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident d=d_ident q=TEq
- e=initialize pv=TPtVirg
- { let (id,fn) = d in
- !Data.add_type_name (P.id2name i);
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- [Ast0.wrap(Ast0.Init(s,fn idtype,id,P.clt2mcode "=" q,e,
- P.clt2mcode ";" pv))] }
- /* function pointer type */
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv))] }
- | decl_ident TOPar eexpr_list_option TCPar TPtVirg
- { [Ast0.wrap(Ast0.MacroDecl($1,P.clt2mcode "(" $2,$3,
- P.clt2mcode ")" $4,P.clt2mcode ";" $5))] }
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))]}
- | s=Ttypedef t=ctype_full id=typedef_ident pv=TPtVirg
- { let s = P.clt2mcode "typedef" s in
- [Ast0.wrap(Ast0.Typedef(s,t,id,P.clt2mcode ";" pv))] }
-
-one_decl_var:
- t=ctype pv=TPtVirg
- { Ast0.wrap(Ast0.TyDecl(t,P.clt2mcode ";" pv)) }
- | s=ioption(storage) t=ctype d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)) }
- | f=funproto { f }
- | s=ioption(storage) t=ctype d=d_ident q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv)) }
- /* type is a typedef name */
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident
- d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.UnInit(s,fn idtype,id,P.clt2mcode ";" pv)) }
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident d=d_ident q=TEq
- e=initialize pv=TPtVirg
- { let (id,fn) = d in
- !Data.add_type_name (P.id2name i);
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.Init(s,fn idtype,id,P.clt2mcode "=" q,e,
- P.clt2mcode ";" pv)) }
- /* function pointer type */
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)) }
- | decl_ident TOPar eexpr_list_option TCPar TPtVirg
- { Ast0.wrap(Ast0.MacroDecl($1,P.clt2mcode "(" $2,$3,
- P.clt2mcode ")" $4,P.clt2mcode ";" $5)) }
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))}
-
-
-d_ident:
- ident list(array_dec)
- { ($1,
- function t ->
- List.fold_right
- (function (l,i,r) ->
- function rest ->
- Ast0.wrap
- (Ast0.Array(rest,P.clt2mcode "[" l,i,P.clt2mcode "]" r)))
- $2 t) }
-
-array_dec: l=TOCro i=option(eexpr) r=TCCro { (l,i,r) }
-
-initialize:
- eexpr
- { Ast0.wrap(Ast0.InitExpr($1)) }
- | TOBrace initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
- | TOBrace TCBrace
- { Ast0.wrap
- (Ast0.InitList(P.clt2mcode "{" $1,Ast0.wrap(Ast0.DOTS []),
- P.clt2mcode "}" $2)) }
- | TMetaInit
- {let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaInit(P.clt2mcode nm clt,pure)) }
-
-initialize2:
- /*arithexpr and not eexpr because can have ambiguity with comma*/
- /*dots and nests probably not allowed at top level, haven't looked into why*/
- arith_expr(eexpr,invalid) { Ast0.wrap(Ast0.InitExpr($1)) }
-| TOBrace initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
-| TOBrace TCBrace
- { Ast0.wrap
- (Ast0.InitList(P.clt2mcode "{" $1,Ast0.wrap(Ast0.DOTS []),
- P.clt2mcode "}" $2)) }
- /* gccext:, labeled elements */
-| list(designator) TEq initialize2
- { Ast0.wrap(Ast0.InitGccExt($1,P.clt2mcode "=" $2,$3)) }
-| ident TDotDot initialize2
- { Ast0.wrap(Ast0.InitGccName($1,P.clt2mcode ":" $2,$3)) } /* in old kernel */
-
-designator:
- | TDot ident
- { Ast0.DesignatorField (P.clt2mcode "." $1,$2) }
- | TOCro eexpr TCCro
- { Ast0.DesignatorIndex (P.clt2mcode "[" $1,$2,P.clt2mcode "]" $3) }
- | TOCro eexpr TEllipsis eexpr TCCro
- { Ast0.DesignatorRange (P.clt2mcode "[" $1,$2,P.clt2mcode "..." $3,
- $4,P.clt2mcode "]" $5) }
-
-initialize_list:
- initialize_list_start { Ast0.wrap(Ast0.DOTS($1)) }
-
-initialize_list_start:
- initialize2 TComma { [$1;Ast0.wrap(Ast0.IComma(P.clt2mcode "," $2))] }
-| initialize2 TComma initialize_list_start
- { $1::Ast0.wrap(Ast0.IComma(P.clt2mcode "," $2))::$3 }
-| d=edots_when(TEllipsis,initialize)
- r=comma_initializers(edots_when(TEllipsis,initialize))
- { (P.mkidots "..." d)::
- (List.concat(List.map (function x -> x (P.mkidots "...")) r)) }
-
-comma_initializers(dotter):
- /* empty */ { [] }
-| d=dotter r=comma_initializers2(dotter)
- { (function dot_builder -> [dot_builder d])::r }
-| i=initialize2 c=TComma r=comma_initializers(dotter)
- { (function dot_builder -> [i; Ast0.wrap(Ast0.IComma(P.clt2mcode "," c))])::
- r }
-
-comma_initializers2(dotter):
- /* empty */ { [] }
-| i=initialize2 c=TComma r=comma_initializers(dotter)
- { (function dot_builder -> [i; Ast0.wrap(Ast0.IComma(P.clt2mcode "," c))])::
- r }
-
-/* a statement that is part of a list */
-decl_statement:
- TMetaStmList
- { let (nm,pure,clt) = $1 in
- [Ast0.wrap(Ast0.MetaStmt(P.clt2mcode nm clt,pure))] }
- | decl_var
- { List.map
- (function x ->
- Ast0.wrap
- (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),x)))
- $1 }
- | statement { [$1] }
- /* this doesn't allow expressions at top level, because the parser doesn't
- know whether there is one. If there is one, this is not sequencible.
- If there is not one, then it is. It seems complicated to get around
- this at the parser level. We would have to have a check afterwards to
- allow this. One case where this would be useful is for a when. Now
- we allow a sequence of whens, so one can be on only statements and
- one can be on only expressions. */
- | TOPar0 t=midzero_list(fun_start,fun_start) TCPar0
- { let (mids,code) = t in
- if List.for_all
- (function x ->
- match Ast0.unwrap x with Ast0.DOTS([]) -> true | _ -> false)
- code
- then []
- else
- [Ast0.wrap(Ast0.Disj(P.clt2mcode "(" $1, code, mids,
- P.clt2mcode ")" $3))] }
-
-/* a statement that is part of a list */
-decl_statement_expr:
- TMetaStmList
- { let (nm,pure,clt) = $1 in
- [Ast0.wrap(Ast0.MetaStmt(P.clt2mcode nm clt,pure))] }
- | decl_var
- { List.map
- (function x ->
- Ast0.wrap
- (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),x)))
- $1 }
- | statement { [$1] }
- /* this doesn't allow expressions at top level, because the parser doesn't
- know whether there is one. If there is one, this is not sequencible.
- If there is not one, then it is. It seems complicated to get around
- this at the parser level. We would have to have a check afterwards to
- allow this. One case where this would be useful is for a when. Now
- we allow a sequence of whens, so one can be on only statements and
- one can be on only expressions. */
- | TOPar0 t=midzero_list(fun_after_stm,fun_after_dots_or) TCPar0
- { let (mids,code) = t in
- if List.for_all (function [] -> true | _ -> false) code
- then []
- else
- let dot_code =
- List.map (function x -> Ast0.wrap(Ast0.DOTS x)) code in
- [Ast0.wrap(Ast0.Disj(P.clt2mcode "(" $1, dot_code, mids,
- P.clt2mcode ")" $3))] }
-
-/*****************************************************************************/
-
-/* The following cannot contain <... ...> at the top level. This can only
-be allowed as an expression when the expression is delimited on both sides
-by expression-specific markers. In that case, the rule eexpr is used, which
-allows <... ...> anywhere. Hopefully, this will not be too much of a problem
-in practice. */
-expr: basic_expr(expr,invalid) { $1 }
-/* allows ... and nests */
-eexpr: basic_expr(eexpr,dot_expressions) { $1 }
-/* allows nests but not .... */
-dexpr: basic_expr(eexpr,nest_expressions) { $1 }
-
-top_eexpr:
- eexpr { Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))) }
-
-invalid:
- TInvalid { raise (Semantic_cocci.Semantic "not matchable") }
-
-dot_expressions:
- TEllipsis { Ast0.wrap(Ast0.Edots(P.clt2mcode "..." $1,None)) }
-| nest_expressions { $1 }
-
-/* not clear what whencode would mean, so just drop it */
-nest_expressions:
- TOEllipsis e=expr_dots(TEllipsis) c=TCEllipsis
- { Ast0.wrap(Ast0.NestExpr(P.clt2mcode "<..." $1,
- Ast0.wrap(Ast0.DOTS(e (P.mkedots "..."))),
- P.clt2mcode "...>" c, None, false)) }
-| TPOEllipsis e=expr_dots(TEllipsis) c=TPCEllipsis
- { Ast0.wrap(Ast0.NestExpr(P.clt2mcode "<+..." $1,
- Ast0.wrap(Ast0.DOTS(e (P.mkedots "..."))),
- P.clt2mcode "...+>" c, None, true)) }
-
-//whenexp: TWhen TNotEq w=eexpr TLineEnd { w }
-
-basic_expr(recurser,primary_extra):
- assign_expr(recurser,primary_extra) { $1 }
-
-assign_expr(r,pe):
- cond_expr(r,pe) { $1 }
- | unary_expr(r,pe) TAssign assign_expr_bis
- { let (op,clt) = $2 in
- Ast0.wrap(Ast0.Assignment($1,P.clt2mcode op clt,
- Ast0.set_arg_exp $3,false)) }
- | unary_expr(r,pe) TEq assign_expr_bis
- { Ast0.wrap
- (Ast0.Assignment
- ($1,P.clt2mcode Ast.SimpleAssign $2,Ast0.set_arg_exp $3,false)) }
-
-assign_expr_bis:
- cond_expr(eexpr,dot_expressions) { $1 }
- | unary_expr(eexpr,dot_expressions) TAssign assign_expr_bis
- { let (op,clt) = $2 in
- Ast0.wrap(Ast0.Assignment($1,P.clt2mcode op clt,
- Ast0.set_arg_exp $3,false)) }
- | unary_expr(eexpr,dot_expressions) TEq assign_expr_bis
- { Ast0.wrap
- (Ast0.Assignment
- ($1,P.clt2mcode Ast.SimpleAssign $2,Ast0.set_arg_exp $3,false)) }
-
-cond_expr(r,pe):
- arith_expr(r,pe) { $1 }
- | l=arith_expr(r,pe) w=TWhy t=option(eexpr) dd=TDotDot r=cond_expr(r,pe)
- { Ast0.wrap(Ast0.CondExpr (l, P.clt2mcode "?" w, t,
- P.clt2mcode ":" dd, r)) }
-
-arith_expr(r,pe):
- cast_expr(r,pe) { $1 }
- | arith_expr(r,pe) TMul arith_expr(r,pe)
- { P.arith_op Ast.Mul $1 $2 $3 }
- | arith_expr(r,pe) TDmOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.arith_op op $1 clt $3 }
- | arith_expr(r,pe) TPlus arith_expr(r,pe)
- { P.arith_op Ast.Plus $1 $2 $3 }
- | arith_expr(r,pe) TMinus arith_expr(r,pe)
- { P.arith_op Ast.Minus $1 $2 $3 }
- | arith_expr(r,pe) TShOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.arith_op op $1 clt $3 }
- | arith_expr(r,pe) TLogOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.logic_op op $1 clt $3 }
- | arith_expr(r,pe) TEqEq arith_expr(r,pe)
- { P.logic_op Ast.Eq $1 $2 $3 }
- | arith_expr(r,pe) TNotEq arith_expr(r,pe)
- { P.logic_op Ast.NotEq $1 $2 $3 }
- | arith_expr(r,pe) TAnd arith_expr(r,pe)
- { P.arith_op Ast.And $1 $2 $3 }
- | arith_expr(r,pe) TOr arith_expr(r,pe)
- { P.arith_op Ast.Or $1 $2 $3 }
- | arith_expr(r,pe) TXor arith_expr(r,pe)
- { P.arith_op Ast.Xor $1 $2 $3 }
- | arith_expr(r,pe) TAndLog arith_expr(r,pe)
- { P.logic_op Ast.AndLog $1 $2 $3 }
- | arith_expr(r,pe) TOrLog arith_expr(r,pe)
- { P.logic_op Ast.OrLog $1 $2 $3 }
-
-cast_expr(r,pe):
- unary_expr(r,pe) { $1 }
- | lp=TOPar t=ctype rp=TCPar e=cast_expr(r,pe)
- { Ast0.wrap(Ast0.Cast (P.clt2mcode "(" lp, t,
- P.clt2mcode ")" rp, e)) }
-
-unary_expr(r,pe):
- postfix_expr(r,pe) { $1 }
- | TInc unary_expr(r,pe)
- { Ast0.wrap(Ast0.Infix ($2, P.clt2mcode Ast.Inc $1)) }
- | TDec unary_expr(r,pe)
- { Ast0.wrap(Ast0.Infix ($2, P.clt2mcode Ast.Dec $1)) }
- | unary_op unary_expr(r,pe)
- { let mcode = $1 in Ast0.wrap(Ast0.Unary($2, mcode)) }
- | TBang unary_expr(r,pe)
- { let mcode = P.clt2mcode Ast.Not $1 in
- Ast0.wrap(Ast0.Unary($2, mcode)) }
- | TSizeof unary_expr(r,pe)
- { Ast0.wrap(Ast0.SizeOfExpr (P.clt2mcode "sizeof" $1, $2)) }
- | s=TSizeof lp=TOPar t=ctype rp=TCPar
- { Ast0.wrap(Ast0.SizeOfType (P.clt2mcode "sizeof" s,
- P.clt2mcode "(" lp,t,
- P.clt2mcode ")" rp)) }
-
-unary_op: TAnd { P.clt2mcode Ast.GetRef $1 }
- | TMul { P.clt2mcode Ast.DeRef $1 }
- | TPlus { P.clt2mcode Ast.UnPlus $1 }
- | TMinus { P.clt2mcode Ast.UnMinus $1 }
- | TTilde { P.clt2mcode Ast.Tilde $1 }
-
-postfix_expr(r,pe):
- primary_expr(r,pe) { $1 }
- | postfix_expr(r,pe) TOCro eexpr TCCro
- { Ast0.wrap(Ast0.ArrayAccess ($1,P.clt2mcode "[" $2,$3,
- P.clt2mcode "]" $4)) }
- | postfix_expr(r,pe) TDot ident
- { Ast0.wrap(Ast0.RecordAccess($1, P.clt2mcode "." $2, $3)) }
- | postfix_expr(r,pe) TPtrOp ident
- { Ast0.wrap(Ast0.RecordPtAccess($1, P.clt2mcode "->" $2,
- $3)) }
- | postfix_expr(r,pe) TInc
- { Ast0.wrap(Ast0.Postfix ($1, P.clt2mcode Ast.Inc $2)) }
- | postfix_expr(r,pe) TDec
- { Ast0.wrap(Ast0.Postfix ($1, P.clt2mcode Ast.Dec $2)) }
- | postfix_expr(r,pe) TOPar eexpr_list_option TCPar
- { Ast0.wrap(Ast0.FunCall($1,P.clt2mcode "(" $2,
- $3,
- P.clt2mcode ")" $4)) }
-
-primary_expr(recurser,primary_extra):
- func_ident { Ast0.wrap(Ast0.Ident($1)) }
- | TInt
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Int x) clt)) }
- | TFloat
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Float x) clt)) }
- | TString
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.String x) clt)) }
- | TChar
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Char x) clt)) }
- | TMetaConst
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.CONST,pure)) }
- | TMetaErr
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaErr(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.ANY,pure)) }
- | TMetaIdExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.ID,pure)) }
- | TMetaLocalIdExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.LocalID,pure)) }
- | TOPar eexpr TCPar
- { Ast0.wrap(Ast0.Paren(P.clt2mcode "(" $1,$2,
- P.clt2mcode ")" $3)) }
- | TOPar0 midzero_list(recurser,eexpr) TCPar0
- { let (mids,code) = $2 in
- Ast0.wrap(Ast0.DisjExpr(P.clt2mcode "(" $1,
- code, mids,
- P.clt2mcode ")" $3)) }
- | primary_extra { $1 }
-
-expr_dots(dotter):
- r=no_dot_start_end(dexpr,edots_when(dotter,eexpr)) { r }
-
-// used in NEST
-no_dot_start_end(grammar,dotter):
- g=grammar dg=list(pair(dotter,grammar))
- { function dot_builder ->
- g :: (List.concat(List.map (function (d,g) -> [dot_builder d;g]) dg)) }
-
-/*****************************************************************************/
-
-pure_ident:
- TIdent { $1 }
-
-meta_ident:
- TRuleName TDot pure_ident { (Some $1,P.id2name $3) }
-
-pure_ident_or_meta_ident:
- pure_ident { (None,P.id2name $1) }
- | meta_ident { $1 }
- | Tlist { (None,"list") }
- | TError { (None,"error") }
- | TType { (None,"type") }
- | TName { (None,"name") }
-
-pure_ident_or_meta_ident_with_not_eq(not_eq):
- i=pure_ident_or_meta_ident l=loption(not_eq) { (i,l) }
-
-not_eq:
- TNotEq i=pure_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- (* pb: constraints not stored with metavars; too lazy to search for
- them in the pattern *)
- then failwith "constraints not allowed in a generated rule file");
- [Ast0.wrap(Ast0.Id(P.id2mcode i))] }
- | TNotEq TOBrace l=comma_list(pure_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map (function i -> Ast0.wrap(Ast0.Id(P.id2mcode i))) l }
-
-not_eqe:
- TNotEq i=pure_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- [Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i))))] }
- | TNotEq TOBrace l=comma_list(pure_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map
- (function i ->
- Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i)))))
- l }
-
-not_ceq:
- TNotEq i=ident_or_const
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- [i] }
- | TNotEq TOBrace l=comma_list(ident_or_const) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- l }
-
-ident_or_const:
- i=pure_ident { Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i)))) }
- | TInt
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Int x) clt)) }
-
-not_pos:
- TNotEq i=meta_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- match i with
- (None,_) -> failwith "constraint must be an inherited variable"
- | (Some rule,name) ->
- let i = (rule,name) in
- P.check_meta(Ast.MetaPosDecl(Ast.NONE,i));
- [i] }
- | TNotEq TOBrace l=comma_list(meta_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map
- (function
- (None,_) ->
- failwith "constraint must be an inherited variable"
- | (Some rule,name) ->
- let i = (rule,name) in
- P.check_meta(Ast.MetaPosDecl(Ast.NONE,i));
- i)
- l }
-
-func_ident: pure_ident
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaId
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaFunc
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaFunc(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaLocalFunc
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaLocalFunc(P.clt2mcode nm clt,constraints,pure)) }
-
-ident: pure_ident
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaId
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-decl_ident:
- TDeclarerId
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaDeclarer
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-iter_ident:
- TIteratorId
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaIterator
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-typedef_ident:
- pure_ident
- { Ast0.wrap(Ast0.TypeName(P.id2mcode $1)) }
- | TMetaType
- { let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure)) }
-
-/*****************************************************************************/
-
-decl_list(decl):
- /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-| decl_list_start(decl)
- {let circle x =
- match Ast0.unwrap x with Ast0.Pcircles(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-decl_list_start(decl):
- one_dec(decl) { [$1] }
-| one_dec(decl) TComma decl_list_start(decl)
- { $1::Ast0.wrap(Ast0.PComma(P.clt2mcode "," $2))::$3 }
-| TEllipsis list(comma_decls(TEllipsis,decl))
- { Ast0.wrap(Ast0.Pdots(P.clt2mcode "..." $1))::
- (List.concat(List.map (function x -> x (P.mkpdots "...")) $2)) }
-
-one_dec(decl):
- decl { $1 }
-| TMetaParamList
- { let (nm,lenname,pure,clt) = $1 in
- let nm = P.clt2mcode nm clt in
- let lenname =
- match lenname with
- Some nm -> Some(P.clt2mcode nm clt)
- | None -> None in
- Ast0.wrap(Ast0.MetaParamList(nm,lenname,pure)) }
-
-comma_decls(dotter,decl):
- TComma dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.PComma(P.clt2mcode "," $1));
- dot_builder $2] }
-| TComma one_dec(decl)
- { function dot_builder ->
- [Ast0.wrap(Ast0.PComma(P.clt2mcode "," $1)); $2] }
-
-/* ---------------------------------------------------------------------- */
-
-error_words:
- TError TWords TEq TOCro cl=comma_list(dexpr) TCCro
- { [Ast0.wrap(Ast0.ERRORWORDS(cl))] }
-
-/* ---------------------------------------------------------------------- */
-/* sequences of statements and expressions */
-
-/* There are number of cases that must be considered:
-
-1. Top level:
- Dots and nests allowed at the beginning or end
- Expressions allowed at the beginning or end
- One function allowed, by itself
-2. A function body:
- Dots and nests allowed at the beginning or end
- Expressions not allowed at the beginning or end
- Functions not allowed
-3. The body of a nest:
- Dots and nests not allowed at the beginning or end
- Expressions allowed at the beginning or end
- Functions not allowed
-4. Whencode:
- Dots and nests not allowed at the beginning but allowed at the end
- Expressions allowed at the beginning or end
- Functions not allowed
-
-These are implemented by the rules minus_toplevel_sequence,
-plus_toplevel_sequence, function_body_sequence, nest_body_sequence, and
-when_body_sequence.
-*/
-/* ------------------------------------------------------------------------ */
-/* Minus top level */
-
-/* doesn't allow only ... */
-minus_start:
- fundecl { [Ast0.wrap(Ast0.DECL($1))] }
-| ctype { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Ty($1))))] }
-| top_init { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.TopInit($1))))] }
-| toplevel_seq_startne(toplevel_after_dots_init)
- { List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1 }
-
-toplevel_seq_startne(after_dots_init):
- a=stm_dots_ell b=after_dots_init { a::b }
-| a=stm_dots_nest b=after_dots_init { a::b }
-| a=stm_dots_nest { [a] }
-| expr toplevel_after_exp { (Ast0.wrap(Ast0.Exp($1)))::$2 }
-| decl_statement_expr toplevel_after_stm { $1@$2 }
-
-toplevel_seq_start(after_dots_init):
- stm_dots after_dots_init { $1::$2 }
-| expr toplevel_after_exp { (Ast0.wrap(Ast0.Exp($1)))::$2 }
-| decl_statement_expr toplevel_after_stm { $1@$2 }
-
-toplevel_after_dots_init:
- TNothing toplevel_after_exp {$2}
-| expr toplevel_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-| decl_statement_expr toplevel_after_stm {$1@$2}
-
-toplevel_after_exp:
- /* empty */ {[]}
-| stm_dots toplevel_after_dots {$1::$2}
-
-toplevel_after_dots:
- /* empty */ {[]}
-| TNothing toplevel_after_exp {$2}
-| expr toplevel_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-| decl_statement_expr toplevel_after_stm {$1@$2}
-
-toplevel_after_stm:
- /* empty */ {[]}
-| stm_dots toplevel_after_dots {$1::$2}
-| decl_statement toplevel_after_stm {$1@$2}
-
-top_init:
- TOInit initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
-
-/* ------------------------------------------------------------------------ */
-/* Plus top level */
-
-/* does allow only ... also allows multiple top-level functions */
-plus_start:
- ctype { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Ty($1))))] }
-| top_init { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.TopInit($1))))] }
-| stm_dots plus_after_dots
- { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-| expr plus_after_exp
- { (Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement_expr plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-plus_after_exp:
- /* empty */ {[]}
-| stm_dots plus_after_dots { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-
-plus_after_dots:
- /* empty */ {[]}
-| TNothing plus_after_exp {$2}
-| expr plus_after_exp
- { (Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement_expr plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-plus_after_stm:
- /* empty */ {[]}
-| stm_dots plus_after_dots { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-/* ------------------------------------------------------------------------ */
-/* Function body */
-
-fun_start:
- fun_after_stm { Ast0.wrap(Ast0.DOTS($1)) }
-
-fun_after_stm:
- /* empty */ {[]}
-| stm_dots fun_after_dots {$1::$2}
-| decl_statement fun_after_stm {$1@$2}
-
-fun_after_dots:
- /* empty */ {[]}
-| TNothing fun_after_exp {$2}
-| expr fun_after_exp {Ast0.wrap(Ast0.Exp($1))::$2}
-| decl_statement_expr fun_after_stm {$1@$2}
-
-fun_after_exp:
- stm_dots fun_after_dots {$1::$2}
-
-/* hack to allow mixing statements and expressions in an or */
-fun_after_dots_or:
- /* empty */ {[]}
-| TNothing fun_after_exp_or {$2}
-| expr fun_after_exp_or {Ast0.wrap(Ast0.Exp($1))::$2}
-| decl_statement_expr fun_after_stm {$1@$2}
-
-fun_after_exp_or:
- /* empty */ {[]}
-| stm_dots fun_after_dots {$1::$2}
-
-/* ------------------------------------------------------------------------ */
-/* Nest body */
-
-nest_start:
- nest_after_dots { Ast0.wrap(Ast0.DOTS($1)) }
-
-nest_after_dots:
- decl_statement_expr nest_after_stm {$1@$2}
-| TNothing nest_after_exp {$2}
-| expr nest_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-
-nest_after_stm:
- /* empty */ {[]}
-| stm_dots nest_after_dots {$1::$2}
-| decl_statement nest_after_stm {$1@$2}
-
-nest_after_exp:
- /* empty */ {[]}
-| stm_dots nest_after_dots {$1::$2}
-
-/* ------------------------------------------------------------------------ */
-/*Whencode*/
-
-when_start:
- expr toplevel_after_exp
- { Ast0.wrap(Ast0.DOTS((Ast0.wrap(Ast0.Exp($1)))::$2)) }
-| decl_statement toplevel_after_stm
- { Ast0.wrap(Ast0.DOTS($1@$2)) }
-
-/* ---------------------------------------------------------------------- */
-
-eexpr_list:
- eexpr_list_start
- {let circle x =
- match Ast0.unwrap x with Ast0.Ecircles(_) -> true | _ -> false in
- let star x =
- match Ast0.unwrap x with Ast0.Estars(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else
- if List.exists star $1
- then Ast0.wrap(Ast0.STARS($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-/* arg expr. may contain a type or a explist metavariable */
-aexpr:
- eexpr
- { Ast0.set_arg_exp $1 }
- | TMetaExpList
- { let (nm,lenname,pure,clt) = $1 in
- let nm = P.clt2mcode nm clt in
- let lenname =
- match lenname with
- Some nm -> Some(P.clt2mcode nm clt)
- | None -> None in
- Ast0.wrap(Ast0.MetaExprList(nm,lenname,pure)) }
- | ctype
- { Ast0.set_arg_exp(Ast0.wrap(Ast0.TypeExp($1))) }
-
-eexpr_list_start:
- aexpr { [$1] }
- | aexpr TComma eexpr_list_start
- { $1::Ast0.wrap(Ast0.EComma(P.clt2mcode "," $2))::$3 }
-
-comma_args(dotter):
- c=TComma d=dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.EComma(P.clt2mcode "," c)); dot_builder d] }
-| TComma aexpr
- { function dot_builder ->
- [Ast0.wrap(Ast0.EComma(P.clt2mcode "," $1)); $2] }
-
-eexpr_list_option: eexpr_list { $1 }
- | /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-
-/****************************************************************************/
-
-// non-empty lists - drop separator
-comma_list(elem):
- separated_nonempty_list(TComma,elem) { $1 }
-
-midzero_list(elem,aft):
- a=elem b=list(mzl(aft))
- { let (mids,code) = List.split b in (mids,(a::code)) }
-
-mzl(elem):
- a=TMid0 b=elem { (P.clt2mcode "|" a, b) }
-
-edots_when(dotter,when_grammar):
- d=dotter { (d,None) }
- | d=dotter TWhen TNotEq w=when_grammar TLineEnd { (d,Some w) }
-
-whens(when_grammar,simple_when_grammar):
- TWhen TNotEq w=when_grammar TLineEnd { [Ast0.WhenNot w] }
- | TWhen TEq w=simple_when_grammar TLineEnd { [Ast0.WhenAlways w] }
- | TWhen comma_list(any_strict) TLineEnd
- { List.map (function x -> Ast0.WhenModifier(x)) $2 }
- | TWhenTrue TNotEq e = eexpr TLineEnd { [Ast0.WhenNotTrue e] }
- | TWhenFalse TNotEq e = eexpr TLineEnd { [Ast0.WhenNotFalse e] }
-
-any_strict:
- TAny { Ast.WhenAny }
- | TStrict { Ast.WhenStrict }
- | TForall { Ast.WhenForall }
- | TExists { Ast.WhenExists }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-iso_main:
- TIsoExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.ExprTag x) e1 el }
-| TIsoArgExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.ArgExprTag x) e1 el }
-| TIsoTestExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.TestExprTag x) e1 el }
-| TIsoStatement s1=single_statement sl=list(iso(single_statement)) EOF
- { P.iso_adjust (function x -> Ast0.StmtTag x) s1 sl }
-| TIsoType t1=ctype tl=list(iso(ctype)) EOF
- { P.iso_adjust (function x -> Ast0.TypeCTag x) t1 tl }
-| TIsoTopLevel e1=nest_start el=list(iso(nest_start)) EOF
- { P.iso_adjust (function x -> Ast0.DotsStmtTag x) e1 el }
-| TIsoDeclaration d1=decl_var dl=list(iso(decl_var)) EOF
- { let check_one = function
- [x] -> x
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "only one variable per declaration in an isomorphism rule") in
- let d1 = check_one d1 in
- let dl =
- List.map
- (function
- Common.Left x -> Common.Left(check_one x)
- | Common.Right x -> Common.Right(check_one x))
- dl in
- P.iso_adjust (function x -> Ast0.DeclTag x) d1 dl }
-
-iso(term):
- TIso t=term { Common.Left t }
- | TRightIso t=term { Common.Right t }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-never_used: TPragma { () }
- | TPArob TMetaPos { () }
- | TScriptData { () }
-
-script_meta_main: py=pure_ident TShOp TRuleName TDot cocci=pure_ident TMPtVirg
- { (P.id2name py, ($3, P.id2name cocci)) }
+++ /dev/null
-/*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*/
-
-
-%{
-
-(* Not clear how to allow function declarations to specify a return type
-and how to allow both to be specified as static, because they are in
-different rules. The rules seem to have to be combined, which would allow
-functions to be declared as local variables *)
-
-(* Not clear how to let a function have a parameter of type void. At the
-moment, void is allowed to be the type of a variable, which is wrong, and a
-parameter needs both a type and an identifier *)
-module Ast0 = Ast0_cocci
-module Ast = Ast_cocci
-module P = Parse_aux
-%}
-
-%token EOF
-
-%token TIdentifier TExpression TStatement TFunction TLocal TType TParameter
-%token TIdExpression TInitialiser
-%token Tlist TFresh TConstant TError TWords TWhy0 TPlus0 TBang0
-%token TPure TContext TGenerated
-%token TTypedef TDeclarer TIterator TName TPosition TPosAny
-%token TUsing TDisable TExtends TDepends TOn TEver TNever TExists TForall
-%token TScript TReverse TNothing
-%token<string> TRuleName
-
-%token<Data.clt> Tchar Tshort Tint Tdouble Tfloat Tlong
-%token<Data.clt> Tvoid Tstruct Tunion Tenum
-%token<Data.clt> Tunsigned Tsigned
-
-%token<Data.clt> Tstatic Tauto Tregister Textern Tinline Ttypedef
-%token<Data.clt> Tconst Tvolatile
-%token<string * Data.clt> Tattr
-
-%token <Data.clt> TIf TElse TWhile TFor TDo TSwitch TCase TDefault TReturn
-%token <Data.clt> TBreak TContinue TGoto TSizeof TFunDecl
-%token <string * Data.clt> TIdent TTypeId TDeclarerId TIteratorId
-
-%token <Parse_aux.idinfo> TMetaId TMetaFunc TMetaLocalFunc
-%token <Parse_aux.idinfo> TMetaIterator TMetaDeclarer
-%token <Parse_aux.expinfo> TMetaErr
-%token <Parse_aux.info> TMetaParam TMetaStm TMetaStmList TMetaType
-%token <Parse_aux.info> TMetaInit
-%token <Parse_aux.list_info> TMetaParamList TMetaExpList
-%token <Parse_aux.typed_info> TMetaExp TMetaIdExp TMetaLocalIdExp TMetaConst
-%token <Parse_aux.pos_info> TMetaPos
-
-%token TArob TArobArob TPArob
-%token <string> TScriptData
-
-%token <Data.clt> TEllipsis TOEllipsis TCEllipsis TPOEllipsis TPCEllipsis
-%token <Data.clt> TWhen TWhenTrue TWhenFalse TAny TStrict TLineEnd
-
-%token <Data.clt> TWhy TDotDot TBang TOPar TOPar0
-%token <Data.clt> TMid0 TCPar TCPar0
-
-%token <string> TPragma TPathIsoFile
-%token <string * Data.clt> TIncludeL TIncludeNL
-%token <Data.clt * token> TDefine
-%token <Data.clt * token * int> TDefineParam
-%token <string * Data.clt> TMinusFile TPlusFile
-
-%token <Data.clt> TInc TDec
-
-%token <string * Data.clt> TString TChar TFloat TInt
-
-%token <Data.clt> TOrLog
-%token <Data.clt> TAndLog
-%token <Data.clt> TOr
-%token <Data.clt> TXor
-%token <Data.clt> TAnd
-%token <Data.clt> TEqEq TNotEq
-%token <Ast_cocci.logicalOp * Data.clt> TLogOp /* TInf TSup TInfEq TSupEq */
-%token <Ast_cocci.arithOp * Data.clt> TShOp /* TShl TShr */
-%token <Ast_cocci.arithOp * Data.clt> TDmOp /* TDiv TMod */
-%token <Data.clt> TPlus TMinus
-%token <Data.clt> TMul TTilde
-
-%token <Data.clt> TOBrace TCBrace TOInit
-%token <Data.clt> TOCro TCCro
-
-%token <Data.clt> TPtrOp
-
-%token TMPtVirg
-%token <Data.clt> TEq TDot TComma TPtVirg
-%token <Ast_cocci.assignOp * Data.clt> TAssign
-
-%token TIso TRightIso TIsoExpression TIsoStatement TIsoDeclaration TIsoType
-%token TIsoTopLevel TIsoArgExpression TIsoTestExpression
-
-%token TInvalid
-
-/* operator precedence */
-%nonassoc TIf
-%nonassoc TElse
-
-%left TOrLog
-%left TAndLog
-%left TOr
-%left TXor
-%left TAnd
-%left TEqEq TNotEq
-%left TLogOp /* TInf TSup TInfEq TSupEq */
-%left TShOp /* TShl TShr */
-%left TPlus TMinus
-%left TMul TDmOp /* TDiv TMod */
-
-%start reinit
-%type <unit> reinit
-
-%start minus_main
-%type <Ast0_cocci.rule> minus_main
-
-%start minus_exp_main
-%type <Ast0_cocci.rule> minus_exp_main
-
-%start plus_main
-%type <Ast0_cocci.rule> plus_main
-
-%start plus_exp_main
-%type <Ast0_cocci.rule> plus_exp_main
-
-%start include_main
-%type <(string,string) Common.either list> include_main
-
-%start iso_rule_name
-%type <Ast_cocci.rulename>
-iso_rule_name
-
-%start rule_name
-%type <Ast_cocci.rulename>
-rule_name
-
-%start meta_main
-%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> meta_main
-
-%start <string * (string * string)> script_meta_main
-
-%start iso_main
-%type <Ast0_cocci.anything list list> iso_main
-
-%start iso_meta_main
-%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> iso_meta_main
-
-%start never_used
-%type <unit> never_used
-
-%%
-
-reinit: { }
-minus_main: minus_body EOF { $1 } | m=minus_body TArobArob { m }
-| m=minus_body TArob { m }
-plus_main: plus_body EOF { $1 } | p=plus_body TArobArob { p }
-| p=plus_body TArob { p }
-minus_exp_main: minus_exp_body EOF { $1 } | m=minus_exp_body TArobArob { m }
-| m=minus_exp_body TArob { m }
-plus_exp_main: plus_exp_body EOF { $1 } | p=plus_exp_body TArobArob { p }
-| p=plus_exp_body TArob { p }
-meta_main: m=metadec { m (!Ast0.rule_name) }
-iso_meta_main: m=metadec { m "" }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-pure:
- TPure { Ast0.Pure }
-| TContext { Ast0.Context }
-| TPure TContext { Ast0.PureContext }
-| TContext TPure { Ast0.PureContext }
-| /* empty */ { Ast0.Impure }
-
-iso_rule_name:
- nm=pure_ident TArob { P.make_iso_rule_name_result (P.id2name nm) }
-
-rule_name:
- nm=ioption(pure_ident) extends d=depends i=loption(choose_iso)
- a=loption(disable) e=exists ee=is_expression TArob
- { P.make_cocci_rule_name_result nm d i a e ee }
- | TGenerated extends d=depends i=loption(choose_iso)
- a=loption(disable) e=exists ee=is_expression TArob
- /* these rules have no name as a cheap way to ensure that no normal
- rule inherits their metavariables or depends on them */
- { P.make_generated_rule_name_result None d i a e ee }
- | TScript TDotDot lang=pure_ident d=depends TArob
- { P.make_script_rule_name_result lang d }
-
-extends:
- /* empty */ { () }
-| TExtends parent=TRuleName
- { !Data.install_bindings (parent) }
-
-depends:
- /* empty */ { Ast.NoDep }
-| TDepends TOn parents=dep { parents }
-
-dep:
- pnrule { $1 }
-| dep TAndLog dep { Ast.AndDep($1, $3) }
-| dep TOrLog dep { Ast.OrDep ($1, $3) }
-
-pnrule:
- TRuleName { Ast.Dep $1 }
-| TBang TRuleName { Ast.AntiDep $2 }
-| TEver TRuleName { Ast.EverDep $2 }
-| TNever TRuleName { Ast.NeverDep $2 }
-| TOPar dep TCPar { $2 }
-
-choose_iso:
- TUsing separated_nonempty_list(TComma,TString) { List.map P.id2name $2 }
-
-disable:
- TDisable separated_nonempty_list(TComma,pure_ident) { List.map P.id2name $2 }
-
-exists:
- TExists { Ast.Exists }
-| TForall { Ast.Forall }
-| TReverse TForall { Ast.ReverseForall }
-| { Ast.Undetermined }
-
-is_expression: // for more flexible parsing of top level expressions
- { false }
-| TExpression { true }
-
-include_main:
- list(incl) TArob { $1 }
-| list(incl) TArobArob { $1 }
-
-incl:
- TUsing TString { Common.Left(P.id2name $2) }
-| TUsing TPathIsoFile { Common.Right $2 }
-
-metadec:
- ar=arity ispure=pure
- kindfn=metakind ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_metadec ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_eq)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic_expi
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_eqe)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity ispure=pure
- kindfn=metakind_atomic_expe
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_ceq)) TMPtVirg
- { P.create_metadec_ne ar ispure kindfn ids }
-| ar=arity TPosition a=option(TPosAny)
- ids=comma_list(pure_ident_or_meta_ident_with_not_eq(not_pos)) TMPtVirg
- (* pb: position variables can't be inherited from normal rules, and then
- there is no way to inherit from a generated rule, so there is no point
- to have a position variable *)
- { (if !Data.in_generating
- then failwith "position variables not allowed in a generated rule file");
- let kindfn arity name pure check_meta constraints =
- let tok = check_meta(Ast.MetaPosDecl(arity,name)) in
- let any = match a with None -> Ast.PER | Some _ -> Ast.ALL in
- !Data.add_pos_meta name constraints any; tok in
- P.create_metadec_ne ar false kindfn ids }
-| ar=arity ispure=pure
- TParameter Tlist TOCro id=pure_ident_or_meta_ident TCCro
- ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_len_metadec ar ispure
- (fun lenname arity name pure check_meta ->
- let tok =
- check_meta(Ast.MetaParamListDecl(arity,name,Some lenname)) in
- !Data.add_paramlist_meta name (Some lenname) pure; tok)
- id ids }
-| ar=arity ispure=pure
- TExpression Tlist TOCro id=pure_ident_or_meta_ident TCCro
- ids=comma_list(pure_ident_or_meta_ident) TMPtVirg
- { P.create_len_metadec ar ispure
- (fun lenname arity name pure check_meta ->
- let tok =
- check_meta(Ast.MetaExpListDecl(arity,name,Some lenname)) in
- !Data.add_explist_meta name (Some lenname) pure; tok)
- id ids }
-
-%inline metakind:
- TFresh TIdentifier
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaFreshIdDecl(arity,name)) in
- !Data.add_id_meta name [] pure; tok) }
-| TParameter
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaParamDecl(arity,name)) in
- !Data.add_param_meta name pure; tok) }
-| TParameter Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaParamListDecl(arity,name,None)) in
- !Data.add_paramlist_meta name None pure; tok) }
-| TExpression Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaExpListDecl(arity,name,None)) in
- !Data.add_explist_meta name None pure; tok) }
-| TType
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaTypeDecl(arity,name)) in
- !Data.add_type_meta name pure; tok) }
-| TInitialiser
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaInitDecl(arity,name)) in
- !Data.add_init_meta name pure; tok) }
-| TStatement
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaStmDecl(arity,name)) in
- !Data.add_stm_meta name pure; tok) }
-| TStatement Tlist
- { (fun arity name pure check_meta ->
- let tok = check_meta(Ast.MetaStmListDecl(arity,name)) in
- !Data.add_stmlist_meta name pure; tok) }
-| TTypedef
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_type_name name; [])
- else raise (Semantic_cocci.Semantic "bad typedef")) }
-| TDeclarer TName
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_declarer_name name; [])
- else raise (Semantic_cocci.Semantic "bad declarer")) }
-| TIterator TName
- { (fun arity (_,name) pure check_meta ->
- if arity = Ast.NONE && pure = Ast0.Impure
- then (!Data.add_iterator_name name; [])
- else raise (Semantic_cocci.Semantic "bad iterator")) }
-
-
-%inline metakind_atomic:
- TIdentifier
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaIdDecl(arity,name)) in
- !Data.add_id_meta name constraints pure; tok) }
-| TFunction
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaFuncDecl(arity,name)) in
- !Data.add_func_meta name constraints pure; tok) }
-| TLocal TFunction
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaLocalFuncDecl(arity,name)) in
- !Data.add_local_func_meta name constraints pure;
- tok) }
-| TDeclarer
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaDeclarerDecl(arity,name)) in
- !Data.add_declarer_meta name constraints pure; tok) }
-| TIterator
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaIteratorDecl(arity,name)) in
- !Data.add_iterator_meta name constraints pure; tok) }
-
-%inline metakind_atomic_expi:
- TError
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaErrDecl(arity,name)) in
- !Data.add_err_meta name constraints pure; tok) }
-| l=option(TLocal) TIdExpression ty=ioption(meta_exp_type)
- { (fun arity name pure check_meta constraints ->
- match l with
- None ->
- !Data.add_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaIdExpDecl(arity,name,ty))
- | Some _ ->
- !Data.add_local_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaLocalIdExpDecl(arity,name,ty))) }
-| l=option(TLocal) TIdExpression m=nonempty_list(TMul)
- { (fun arity name pure check_meta constraints ->
- let ty = Some [P.ty_pointerify Type_cocci.Unknown m] in
- match l with
- None ->
- !Data.add_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaIdExpDecl(arity,name,ty))
- | Some _ ->
- !Data.add_local_idexp_meta ty name constraints pure;
- check_meta(Ast.MetaLocalIdExpDecl(arity,name,ty))) }
-| TExpression m=nonempty_list(TMul)
- { (fun arity name pure check_meta constraints ->
- let ty = Some [P.ty_pointerify Type_cocci.Unknown m] in
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-| vl=meta_exp_type TOCro TCCro
- { (fun arity name pure check_meta constraints ->
- let ty = Some (List.map (function x -> Type_cocci.Array x) vl) in
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-| TConstant ty=ioption(meta_exp_type)
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaConstDecl(arity,name,ty)) in
- !Data.add_const_meta ty name constraints pure; tok) }
-
-%inline metakind_atomic_expe:
- TExpression
- { (fun arity name pure check_meta constraints ->
- let tok = check_meta(Ast.MetaExpDecl(arity,name,None)) in
- !Data.add_exp_meta None name constraints pure; tok) }
-| vl=meta_exp_type // no error if use $1 but doesn't type check
- { (fun arity name pure check_meta constraints ->
- let ty = Some vl in
- List.iter
- (function c ->
- match Ast0.unwrap c with
- Ast0.Constant(_) ->
- if not
- (List.exists
- (function
- Type_cocci.BaseType(Type_cocci.IntType) -> true
- | Type_cocci.BaseType(Type_cocci.ShortType) -> true
- | Type_cocci.BaseType(Type_cocci.LongType) -> true
- | _ -> false)
- vl)
- then failwith "metavariable with int constraint must be an int"
- | _ -> ())
- constraints;
- let tok = check_meta(Ast.MetaExpDecl(arity,name,ty)) in
- !Data.add_exp_meta ty name constraints pure; tok) }
-
-
-meta_exp_type:
- t=ctype
- { [Ast0_cocci.ast0_type_to_type t] }
-| TOBrace t=comma_list(ctype) TCBrace m=list(TMul)
- { List.map
- (function x -> P.ty_pointerify (Ast0_cocci.ast0_type_to_type x) m)
- t }
-
-arity: TBang0 { Ast.UNIQUE }
- | TWhy0 { Ast.OPT }
- | TPlus0 { Ast.MULTI }
- | /* empty */ { Ast.NONE }
-
-generic_ctype_full:
- q=ctype_qualif_opt ty=Tchar
- { q (Ast0.wrap(Ast0.BaseType(Ast.CharType,[P.clt2mcode "char" ty]))) }
- | q=ctype_qualif_opt ty=Tshort
- { q (Ast0.wrap(Ast0.BaseType(Ast.ShortType,[P.clt2mcode "short" ty])))}
- | q=ctype_qualif_opt ty=Tint
- { q (Ast0.wrap(Ast0.BaseType(Ast.IntType,[P.clt2mcode "int" ty]))) }
- | t=Tdouble
- { Ast0.wrap(Ast0.BaseType(Ast.DoubleType,[P.clt2mcode "double" t])) }
- | t=Tfloat
- { Ast0.wrap(Ast0.BaseType(Ast.FloatType,[P.clt2mcode "float" t])) }
- | q=ctype_qualif_opt ty=Tlong
- { q (Ast0.wrap(Ast0.BaseType(Ast.LongType,[P.clt2mcode "long" ty]))) }
- | q=ctype_qualif_opt ty=Tlong ty1=Tlong
- { q (Ast0.wrap
- (Ast0.BaseType
- (Ast.LongLongType,
- [P.clt2mcode "long" ty;P.clt2mcode "long" ty1]))) }
- | s=Tenum i=ident
- { Ast0.wrap(Ast0.EnumName(P.clt2mcode "enum" s, i)) }
- | s=struct_or_union i=ident
- { Ast0.wrap(Ast0.StructUnionName(s, Some i)) }
- | s=struct_or_union i=ioption(ident)
- l=TOBrace d=struct_decl_list r=TCBrace
- { (if i = None && !Data.in_iso
- then failwith "structures must be named in the iso file");
- Ast0.wrap(Ast0.StructUnionDef(Ast0.wrap(Ast0.StructUnionName(s, i)),
- P.clt2mcode "{" l,
- d, P.clt2mcode "}" r)) }
- | s=TMetaType l=TOBrace d=struct_decl_list r=TCBrace
- { let (nm,pure,clt) = s in
- let ty =
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure)) in
- Ast0.wrap
- (Ast0.StructUnionDef(ty,P.clt2mcode "{" l,d,P.clt2mcode "}" r)) }
- | r=TRuleName TDot p=TIdent
- { let nm = (r,P.id2name p) in
- (* this is only possible when we are in a metavar decl. Otherwise,
- it will be represented already as a MetaType *)
- let _ = P.check_meta(Ast.MetaTypeDecl(Ast.NONE,nm)) in
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm (P.id2clt p),
- Ast0.Impure (*will be ignored*))) }
- | p=TTypeId
- { Ast0.wrap(Ast0.TypeName(P.id2mcode p)) }
- | q=ctype_qualif_opt p=TMetaType
- { let (nm,pure,clt) = p in
- q (Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure))) }
-
-generic_ctype:
- q=ctype_qualif { q None }
- | generic_ctype_full { $1 }
-
-struct_or_union:
- s=Tstruct { P.clt2mcode Ast.Struct s }
- | u=Tunion { P.clt2mcode Ast.Union u }
-
-struct_decl:
- TNothing { [] }
- | t=ctype d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- [Ast0.wrap(Ast0.UnInit(None,fn t,id,P.clt2mcode ";" pv))] }
- | t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.UnInit(None,fn t,id,P.clt2mcode ";" pv))] }
- | cv=ioption(const_vol) i=pure_ident d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- [Ast0.wrap(Ast0.UnInit(None,fn idtype,id,P.clt2mcode ";" pv))] }
-
-struct_decl_list:
- struct_decl_list_start { Ast0.wrap(Ast0.DOTS($1)) }
-
-struct_decl_list_start:
- struct_decl { $1 }
-| struct_decl struct_decl_list_start { $1@$2 }
-| d=edots_when(TEllipsis,struct_decl) r=continue_struct_decl_list
- { (P.mkddots "..." d)::r }
-
-continue_struct_decl_list:
- /* empty */ { [] }
-| struct_decl struct_decl_list_start { $1@$2 }
-| struct_decl { $1 }
-
-ctype:
- cv=ioption(const_vol) ty=generic_ctype m=list(TMul)
- { P.pointerify (P.make_cv cv ty) m }
- | cv=ioption(const_vol) t=Tvoid m=nonempty_list(TMul)
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- P.pointerify (P.make_cv cv ty) m }
- | lp=TOPar0 t=midzero_list(ctype,ctype) rp=TCPar0
- /* more hacks */
- { let (mids,code) = t in
- Ast0.wrap
- (Ast0.DisjType(P.clt2mcode "(" lp,code,mids, P.clt2mcode ")" rp)) }
-
-ctype_full:
- cv=ioption(const_vol) ty=generic_ctype_full m=list(TMul)
- { P.pointerify (P.make_cv cv ty) m }
- | cv=ioption(const_vol) t=Tvoid m=nonempty_list(TMul)
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- P.pointerify (P.make_cv cv ty) m }
- | lp=TOPar0 t=midzero_list(ctype,ctype) rp=TCPar0
- /* more hacks */
- { let (mids,code) = t in
- Ast0.wrap
- (Ast0.DisjType(P.clt2mcode "(" lp,code,mids, P.clt2mcode ")" rp)) }
-
-
-fn_ctype: // allows metavariables
- ty=generic_ctype m=list(TMul) { P.pointerify ty m }
- | t=Tvoid m=list(TMul)
- { P.pointerify
- (Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])))
- m }
-
-%inline ctype_qualif:
- r=Tunsigned
- { function x -> Ast0.wrap(Ast0.Signed(P.clt2mcode Ast.Unsigned r,x)) }
-| r=Tsigned
- { function x -> Ast0.wrap(Ast0.Signed(P.clt2mcode Ast.Signed r,x)) }
-
-%inline ctype_qualif_opt:
- s=ctype_qualif { function x -> s (Some x) }
-| /* empty */ { function x -> x }
-
-/*****************************************************************************/
-
-/* have to inline everything to avoid conflicts? switch to proper
-declarations, statements, and expressions for the subterms */
-
-minus_body:
- f=loption(filespec)
- b=loption(minus_start)
- ew=loption(error_words)
- { match f@b@ew with
- [] -> raise (Semantic_cocci.Semantic "minus slice can't be empty")
- | code -> Top_level.top_level code }
-
-plus_body:
- f=loption(filespec)
- b=loption(plus_start)
- ew=loption(error_words)
- { Top_level.top_level (f@b@ew) }
-
-minus_exp_body:
- f=loption(filespec)
- b=top_eexpr
- ew=loption(error_words)
- { match f@[b]@ew with
- [] -> raise (Semantic_cocci.Semantic "minus slice can't be empty")
- | code -> Top_level.top_level code }
-
-plus_exp_body:
- f=loption(filespec)
- b=top_eexpr
- ew=loption(error_words)
- { Top_level.top_level (f@[b]@ew) }
-
-filespec:
- TMinusFile TPlusFile
- { [Ast0.wrap
- (Ast0.FILEINFO(P.id2mcode $1,
- P.id2mcode $2))] }
-
-includes:
- TIncludeL
- { Ast0.wrap
- (Ast0.Include(P.clt2mcode "#include" (P.drop_aft (P.id2clt $1)),
- let (arity,ln,lln,offset,col,strbef,straft,pos) =
- P.id2clt $1 in
- let clt =
- (arity,ln,lln,offset,0,strbef,straft,pos) in
- P.clt2mcode
- (Ast.Local (Parse_aux.str2inc (P.id2name $1)))
- (P.drop_bef clt))) }
-| TIncludeNL
- { Ast0.wrap
- (Ast0.Include(P.clt2mcode "#include" (P.drop_aft (P.id2clt $1)),
- let (arity,ln,lln,offset,col,strbef,straft,pos) =
- P.id2clt $1 in
- let clt =
- (arity,ln,lln,offset,0,strbef,straft,pos) in
- P.clt2mcode
- (Ast.NonLocal (Parse_aux.str2inc (P.id2name $1)))
- (P.drop_bef clt))) }
-| d=defineop t=ctype TLineEnd
- { let ty = Ast0.wrap(Ast0.TopExp(Ast0.wrap(Ast0.TypeExp(t)))) in
- d (Ast0.wrap(Ast0.DOTS([ty]))) }
-| defineop b=toplevel_seq_start(toplevel_after_dots) TLineEnd
- { let body =
- match b with
- [e] ->
- (match Ast0.unwrap e with
- Ast0.Exp(e1) ->
- [Ast0.rewrap e (Ast0.TopExp(Ast0.set_arg_exp (e1)))]
- | _ -> b)
- | _ -> b in
- $1 (Ast0.wrap(Ast0.DOTS(body))) }
-
-defineop:
- TDefine
- { let (clt,ident) = $1 in
- function body ->
- Ast0.wrap
- (Ast0.Define
- (P.clt2mcode "#define" clt,
- (match ident with
- TMetaId((nm,constraints,pure,clt)) ->
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure))
- | TIdent(nm_pure) ->
- Ast0.wrap(Ast0.Id(P.id2mcode nm_pure))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "unexpected name for a #define")),
- Ast0.wrap Ast0.NoParams,
- body)) }
-| TDefineParam define_param_list_option TCPar
- { let (clt,ident,parenoff) = $1 in
- let (arity,line,lline,offset,col,strbef,straft,pos) = clt in
- let lp =
- P.clt2mcode "(" (arity,line,lline,parenoff,0,[],[],Ast0.NoMetaPos) in
- function body ->
- Ast0.wrap
- (Ast0.Define
- (P.clt2mcode "#define" clt,
- (match ident with
- TMetaId((nm,constraints,pure,clt)) ->
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure))
- | TIdent(nm_pure) ->
- Ast0.wrap(Ast0.Id(P.id2mcode nm_pure))
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "unexpected name for a #define")),
- Ast0.wrap (Ast0.DParams (lp,$2,P.clt2mcode ")" $3)),body)) }
-
-/* ---------------------------------------------------------------------- */
-
-define_param_list: define_param_list_start
- {let circle x =
- match Ast0.unwrap x with Ast0.DPcircles(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-define_param_list_start:
- ident { [Ast0.wrap(Ast0.DParam $1)] }
- | ident TComma define_param_list_start
- { Ast0.wrap(Ast0.DParam $1)::
- Ast0.wrap(Ast0.DPComma(P.clt2mcode "," $2))::$3 }
- | d=TEllipsis r=list(dp_comma_args(TEllipsis))
- { (P.mkdpdots "..." d)::
- (List.concat (List.map (function x -> x (P.mkdpdots "...")) r)) }
-
-dp_comma_args(dotter):
- c=TComma d=dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.DPComma(P.clt2mcode "," c)); dot_builder d] }
-| TComma ident
- { function dot_builder ->
- [Ast0.wrap(Ast0.DPComma(P.clt2mcode "," $1));
- Ast0.wrap(Ast0.DParam $2)] }
-
-define_param_list_option: define_param_list { $1 }
- | /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-
-/*****************************************************************************/
-
-funproto:
- s=ioption(storage) t=ctype
- id=func_ident lp=TOPar d=decl_list(name_opt_decl) rp=TCPar pt=TPtVirg
- { Ast0.wrap
- (Ast0.UnInit
- (s,
- Ast0.wrap
- (Ast0.FunctionType(Some t,
- P.clt2mcode "(" lp, d, P.clt2mcode ")" rp)),
- id, P.clt2mcode ";" pt)) }
-| s=ioption(storage) t=Tvoid
- id=func_ident lp=TOPar d=decl_list(name_opt_decl) rp=TCPar pt=TPtVirg
- { let t = Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- Ast0.wrap
- (Ast0.UnInit
- (s,
- Ast0.wrap
- (Ast0.FunctionType(Some t,
- P.clt2mcode "(" lp, d, P.clt2mcode ")" rp)),
- id, P.clt2mcode ";" pt)) }
-
-
-fundecl:
- f=fninfo
- TFunDecl i=func_ident lp=TOPar d=decl_list(decl) rp=TCPar
- lb=TOBrace b=fun_start rb=TCBrace
- { Ast0.wrap(Ast0.FunDecl((Ast0.default_info(),Ast0.context_befaft()),
- f, i,
- P.clt2mcode "(" lp, d,
- P.clt2mcode ")" rp,
- P.clt2mcode "{" lb, b,
- P.clt2mcode "}" rb)) }
-
-fninfo:
- /* empty */ { [] }
- | storage fninfo
- { try
- let _ =
- List.find (function Ast0.FStorage(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate storage")
- with Not_found -> (Ast0.FStorage($1))::$2 }
- | t=fn_ctype r=fninfo_nt { (Ast0.FType(t))::r }
- | Tinline fninfo
- { try
- let _ = List.find (function Ast0.FInline(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate inline")
- with Not_found -> (Ast0.FInline(P.clt2mcode "inline" $1))::$2 }
- | Tattr fninfo
- { try
- let _ = List.find (function Ast0.FAttr(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "multiple attributes")
- with Not_found -> (Ast0.FAttr(P.id2mcode $1))::$2 }
-
-fninfo_nt:
- /* empty */ { [] }
- | storage fninfo_nt
- { try
- let _ =
- List.find (function Ast0.FStorage(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate storage")
- with Not_found -> (Ast0.FStorage($1))::$2 }
- | Tinline fninfo_nt
- { try
- let _ = List.find (function Ast0.FInline(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate inline")
- with Not_found -> (Ast0.FInline(P.clt2mcode "inline" $1))::$2 }
- | Tattr fninfo_nt
- { try
- let _ = List.find (function Ast0.FAttr(_) -> true | _ -> false) $2 in
- raise (Semantic_cocci.Semantic "duplicate init")
- with Not_found -> (Ast0.FAttr(P.id2mcode $1))::$2 }
-
-storage:
- s=Tstatic { P.clt2mcode Ast.Static s }
- | s=Tauto { P.clt2mcode Ast.Auto s }
- | s=Tregister { P.clt2mcode Ast.Register s }
- | s=Textern { P.clt2mcode Ast.Extern s }
-
-decl: t=ctype i=ident
- { Ast0.wrap(Ast0.Param(t, Some i)) }
- | t=fn_ctype lp=TOPar s=TMul i=ident rp=TCPar
- lp1=TOPar d=decl_list(name_opt_decl) rp1=TCPar
- { let fnptr =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp,P.clt2mcode "*" s,P.clt2mcode ")" rp,
- P.clt2mcode "(" lp1,d,P.clt2mcode ")" rp1)) in
- Ast0.wrap(Ast0.Param(fnptr, Some i)) }
- | t=Tvoid
- { let ty =
- Ast0.wrap(Ast0.BaseType(Ast.VoidType,[P.clt2mcode "void" t])) in
- Ast0.wrap(Ast0.VoidParam(ty)) }
- | TMetaParam
- { let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaParam(P.clt2mcode nm clt,pure)) }
-
-name_opt_decl:
- decl { $1 }
- | t=ctype { Ast0.wrap(Ast0.Param(t, None)) }
- | t=fn_ctype lp=TOPar s=TMul rp=TCPar
- lp1=TOPar d=decl_list(name_opt_decl) rp1=TCPar
- { let fnptr =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp,P.clt2mcode "*" s,P.clt2mcode ")" rp,
- P.clt2mcode "(" lp1,d,P.clt2mcode ")" rp1)) in
- Ast0.wrap(Ast0.Param(fnptr, None)) }
-
-const_vol:
- Tconst { P.clt2mcode Ast.Const $1 }
- | Tvolatile { P.clt2mcode Ast.Volatile $1 }
-
-/*****************************************************************************/
-
-statement:
- includes { $1 } /* shouldn't be allowed to be a single_statement... */
-| TMetaStm
- { P.meta_stm $1 }
-| expr TPtVirg
- { P.exp_stm $1 $2 }
-| TIf TOPar eexpr TCPar single_statement %prec TIf
- { P.ifthen $1 $2 $3 $4 $5 }
-| TIf TOPar eexpr TCPar single_statement TElse single_statement
- { P.ifthenelse $1 $2 $3 $4 $5 $6 $7 }
-| TFor TOPar option(eexpr) TPtVirg option(eexpr) TPtVirg
- option(eexpr) TCPar single_statement
- { P.forloop $1 $2 $3 $4 $5 $6 $7 $8 $9 }
-| TWhile TOPar eexpr TCPar single_statement
- { P.whileloop $1 $2 $3 $4 $5 }
-| TDo single_statement TWhile TOPar eexpr TCPar TPtVirg
- { P.doloop $1 $2 $3 $4 $5 $6 $7 }
-| iter_ident TOPar eexpr_list_option TCPar single_statement
- { P.iterator $1 $2 $3 $4 $5 }
-| TSwitch TOPar eexpr TCPar TOBrace list(case_line) TCBrace
- { P.switch $1 $2 $3 $4 $5 $6 $7 }
-| TReturn eexpr TPtVirg { P.ret_exp $1 $2 $3 }
-| TReturn TPtVirg { P.ret $1 $2 }
-| TBreak TPtVirg { P.break $1 $2 }
-| TContinue TPtVirg { P.cont $1 $2 }
-| ident TDotDot { P.label $1 $2 }
-| TGoto ident TPtVirg { P.goto $1 $2 $3 }
-| TOBrace fun_start TCBrace
- { P.seq $1 $2 $3 }
-
-stm_dots:
- TEllipsis w=list(whenppdecs)
- { Ast0.wrap(Ast0.Dots(P.clt2mcode "..." $1, List.concat w)) }
-| TOEllipsis w=list(whenppdecs) b=nest_start c=TCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<..." $1, b,
- P.clt2mcode "...>" c, List.concat w, false)) }
-| TPOEllipsis w=list(whenppdecs) b=nest_start c=TPCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<+..." $1, b,
- P.clt2mcode "...+>" c, List.concat w, true)) }
-
-%inline stm_dots_ell:
- a=TEllipsis w=list(whenppdecs)
- { Ast0.wrap(Ast0.Dots(P.clt2mcode "..." a, List.concat w)) }
-
-%inline stm_dots_nest:
- a=TOEllipsis w=list(whenppdecs) b=nest_start c=TCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<..." a, b,
- P.clt2mcode "...>" c, List.concat w, false)) }
-| a=TPOEllipsis w=list(whenppdecs) b=nest_start c=TPCEllipsis
- { Ast0.wrap(Ast0.Nest(P.clt2mcode "<+..." a, b,
- P.clt2mcode "...+>" c, List.concat w, true)) }
-
-whenppdecs: w=whens(when_start,rule_elem_statement)
- { w }
-
-/* a statement that fits into a single rule_elem. should nests be included?
-what about statement metavariables? */
-rule_elem_statement:
- one_decl_var
- { Ast0.wrap(Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),$1)) }
-| expr TPtVirg { P.exp_stm $1 $2 }
-| TReturn eexpr TPtVirg { P.ret_exp $1 $2 $3 }
-| TReturn TPtVirg { P.ret $1 $2 }
-| TBreak TPtVirg { P.break $1 $2 }
-| TContinue TPtVirg { P.cont $1 $2 }
-| TOPar0 midzero_list(rule_elem_statement,rule_elem_statement) TCPar0
- { let (mids,code) = $2 in
- Ast0.wrap
- (Ast0.Disj(P.clt2mcode "(" $1,
- List.map (function x -> Ast0.wrap(Ast0.DOTS([x]))) code,
- mids, P.clt2mcode ")" $3)) }
-
-/* a statement on its own */
-single_statement:
- statement { $1 }
- | TOPar0 midzero_list(statement,statement) TCPar0
- /* degenerate case, elements are single statements and thus don't
- contain dots */
- { let (mids,code) = $2 in
- Ast0.wrap
- (Ast0.Disj(P.clt2mcode "(" $1,
- List.map (function x -> Ast0.wrap(Ast0.DOTS([x]))) code,
- mids, P.clt2mcode ")" $3)) }
-
-case_line:
- TDefault TDotDot fun_start
- { Ast0.wrap(Ast0.Default(P.clt2mcode "default" $1,P.clt2mcode ":" $2,$3)) }
- | TCase eexpr TDotDot fun_start
- { Ast0.wrap(Ast0.Case(P.clt2mcode "case" $1,$2,P.clt2mcode ":" $3,$4)) }
-
-/* In the following, an identifier as a type is not fully supported. Indeed,
-the language is ambiguous: what is foo * bar; */
-/* The AST DisjDecl cannot be generated because it would be ambiguous with
-a disjunction on a statement with a declaration in each branch */
-decl_var:
- t=ctype pv=TPtVirg
- { [Ast0.wrap(Ast0.TyDecl(t,P.clt2mcode ";" pv))] }
- | s=ioption(storage) t=ctype d=comma_list(d_ident) pv=TPtVirg
- { List.map
- (function (id,fn) ->
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)))
- d }
- | f=funproto { [f] }
- | s=ioption(storage) t=ctype d=d_ident q=TEq e=initialize pv=TPtVirg
- {let (id,fn) = d in
- [Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))]}
- /* type is a typedef name */
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident
- d=comma_list(d_ident) pv=TPtVirg
- { List.map
- (function (id,fn) ->
- let idtype =
- P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.UnInit(s,fn idtype,id,P.clt2mcode ";" pv)))
- d }
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident d=d_ident q=TEq
- e=initialize pv=TPtVirg
- { let (id,fn) = d in
- !Data.add_type_name (P.id2name i);
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- [Ast0.wrap(Ast0.Init(s,fn idtype,id,P.clt2mcode "=" q,e,
- P.clt2mcode ";" pv))] }
- /* function pointer type */
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv))] }
- | decl_ident TOPar eexpr_list_option TCPar TPtVirg
- { [Ast0.wrap(Ast0.MacroDecl($1,P.clt2mcode "(" $2,$3,
- P.clt2mcode ")" $4,P.clt2mcode ";" $5))] }
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- [Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))]}
- | s=Ttypedef t=ctype_full id=typedef_ident pv=TPtVirg
- { let s = P.clt2mcode "typedef" s in
- [Ast0.wrap(Ast0.Typedef(s,t,id,P.clt2mcode ";" pv))] }
-
-one_decl_var:
- t=ctype pv=TPtVirg
- { Ast0.wrap(Ast0.TyDecl(t,P.clt2mcode ";" pv)) }
- | s=ioption(storage) t=ctype d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)) }
- | f=funproto { f }
- | s=ioption(storage) t=ctype d=d_ident q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv)) }
- /* type is a typedef name */
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident
- d=d_ident pv=TPtVirg
- { let (id,fn) = d in
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.UnInit(s,fn idtype,id,P.clt2mcode ";" pv)) }
- | s=ioption(storage) cv=ioption(const_vol) i=pure_ident d=d_ident q=TEq
- e=initialize pv=TPtVirg
- { let (id,fn) = d in
- !Data.add_type_name (P.id2name i);
- let idtype = P.make_cv cv (Ast0.wrap (Ast0.TypeName(P.id2mcode i))) in
- Ast0.wrap(Ast0.Init(s,fn idtype,id,P.clt2mcode "=" q,e,
- P.clt2mcode ";" pv)) }
- /* function pointer type */
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- Ast0.wrap(Ast0.UnInit(s,fn t,id,P.clt2mcode ";" pv)) }
- | decl_ident TOPar eexpr_list_option TCPar TPtVirg
- { Ast0.wrap(Ast0.MacroDecl($1,P.clt2mcode "(" $2,$3,
- P.clt2mcode ")" $4,P.clt2mcode ";" $5)) }
- | s=ioption(storage)
- t=fn_ctype lp1=TOPar st=TMul d=d_ident rp1=TCPar
- lp2=TOPar p=decl_list(name_opt_decl) rp2=TCPar
- q=TEq e=initialize pv=TPtVirg
- { let (id,fn) = d in
- let t =
- Ast0.wrap
- (Ast0.FunctionPointer
- (t,P.clt2mcode "(" lp1,P.clt2mcode "*" st,P.clt2mcode ")" rp1,
- P.clt2mcode "(" lp2,p,P.clt2mcode ")" rp2)) in
- Ast0.wrap(Ast0.Init(s,fn t,id,P.clt2mcode "=" q,e,P.clt2mcode ";" pv))}
-
-
-d_ident:
- ident list(array_dec)
- { ($1,
- function t ->
- List.fold_right
- (function (l,i,r) ->
- function rest ->
- Ast0.wrap
- (Ast0.Array(rest,P.clt2mcode "[" l,i,P.clt2mcode "]" r)))
- $2 t) }
-
-array_dec: l=TOCro i=option(eexpr) r=TCCro { (l,i,r) }
-
-initialize:
- eexpr
- { Ast0.wrap(Ast0.InitExpr($1)) }
- | TOBrace initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
- | TOBrace TCBrace
- { Ast0.wrap
- (Ast0.InitList(P.clt2mcode "{" $1,Ast0.wrap(Ast0.DOTS []),
- P.clt2mcode "}" $2)) }
- | TMetaInit
- {let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaInit(P.clt2mcode nm clt,pure)) }
-
-initialize2:
- /*arithexpr and not eexpr because can have ambiguity with comma*/
- /*dots and nests probably not allowed at top level, haven't looked into why*/
- arith_expr(eexpr,invalid) { Ast0.wrap(Ast0.InitExpr($1)) }
-| TOBrace initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
-| TOBrace TCBrace
- { Ast0.wrap
- (Ast0.InitList(P.clt2mcode "{" $1,Ast0.wrap(Ast0.DOTS []),
- P.clt2mcode "}" $2)) }
- /* gccext:, labeled elements */
-| list(designator) TEq initialize2
- { Ast0.wrap(Ast0.InitGccExt($1,P.clt2mcode "=" $2,$3)) }
-| ident TDotDot initialize2
- { Ast0.wrap(Ast0.InitGccName($1,P.clt2mcode ":" $2,$3)) } /* in old kernel */
-
-designator:
- | TDot ident
- { Ast0.DesignatorField (P.clt2mcode "." $1,$2) }
- | TOCro eexpr TCCro
- { Ast0.DesignatorIndex (P.clt2mcode "[" $1,$2,P.clt2mcode "]" $3) }
- | TOCro eexpr TEllipsis eexpr TCCro
- { Ast0.DesignatorRange (P.clt2mcode "[" $1,$2,P.clt2mcode "..." $3,
- $4,P.clt2mcode "]" $5) }
-
-initialize_list:
- initialize_list_start { Ast0.wrap(Ast0.DOTS($1)) }
-
-initialize_list_start:
- initialize2 TComma { [$1;Ast0.wrap(Ast0.IComma(P.clt2mcode "," $2))] }
-| initialize2 TComma initialize_list_start
- { $1::Ast0.wrap(Ast0.IComma(P.clt2mcode "," $2))::$3 }
-| d=edots_when(TEllipsis,initialize)
- r=comma_initializers(edots_when(TEllipsis,initialize))
- { (P.mkidots "..." d)::
- (List.concat(List.map (function x -> x (P.mkidots "...")) r)) }
-
-comma_initializers(dotter):
- /* empty */ { [] }
-| d=dotter r=comma_initializers2(dotter)
- { (function dot_builder -> [dot_builder d])::r }
-| i=initialize2 c=TComma r=comma_initializers(dotter)
- { (function dot_builder -> [i; Ast0.wrap(Ast0.IComma(P.clt2mcode "," c))])::
- r }
-
-comma_initializers2(dotter):
- /* empty */ { [] }
-| i=initialize2 c=TComma r=comma_initializers(dotter)
- { (function dot_builder -> [i; Ast0.wrap(Ast0.IComma(P.clt2mcode "," c))])::
- r }
-
-/* a statement that is part of a list */
-decl_statement:
- TMetaStmList
- { let (nm,pure,clt) = $1 in
- [Ast0.wrap(Ast0.MetaStmt(P.clt2mcode nm clt,pure))] }
- | decl_var
- { List.map
- (function x ->
- Ast0.wrap
- (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),x)))
- $1 }
- | statement { [$1] }
- /* this doesn't allow expressions at top level, because the parser doesn't
- know whether there is one. If there is one, this is not sequencible.
- If there is not one, then it is. It seems complicated to get around
- this at the parser level. We would have to have a check afterwards to
- allow this. One case where this would be useful is for a when. Now
- we allow a sequence of whens, so one can be on only statements and
- one can be on only expressions. */
- | TOPar0 t=midzero_list(fun_start,fun_start) TCPar0
- { let (mids,code) = t in
- if List.for_all
- (function x ->
- match Ast0.unwrap x with Ast0.DOTS([]) -> true | _ -> false)
- code
- then []
- else
- [Ast0.wrap(Ast0.Disj(P.clt2mcode "(" $1, code, mids,
- P.clt2mcode ")" $3))] }
-
-/* a statement that is part of a list */
-decl_statement_expr:
- TMetaStmList
- { let (nm,pure,clt) = $1 in
- [Ast0.wrap(Ast0.MetaStmt(P.clt2mcode nm clt,pure))] }
- | decl_var
- { List.map
- (function x ->
- Ast0.wrap
- (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),x)))
- $1 }
- | statement { [$1] }
- /* this doesn't allow expressions at top level, because the parser doesn't
- know whether there is one. If there is one, this is not sequencible.
- If there is not one, then it is. It seems complicated to get around
- this at the parser level. We would have to have a check afterwards to
- allow this. One case where this would be useful is for a when. Now
- we allow a sequence of whens, so one can be on only statements and
- one can be on only expressions. */
- | TOPar0 t=midzero_list(fun_after_stm,fun_after_dots_or) TCPar0
- { let (mids,code) = t in
- if List.for_all (function [] -> true | _ -> false) code
- then []
- else
- let dot_code =
- List.map (function x -> Ast0.wrap(Ast0.DOTS x)) code in
- [Ast0.wrap(Ast0.Disj(P.clt2mcode "(" $1, dot_code, mids,
- P.clt2mcode ")" $3))] }
-
-/*****************************************************************************/
-
-/* The following cannot contain <... ...> at the top level. This can only
-be allowed as an expression when the expression is delimited on both sides
-by expression-specific markers. In that case, the rule eexpr is used, which
-allows <... ...> anywhere. Hopefully, this will not be too much of a problem
-in practice. */
-expr: basic_expr(expr,invalid) { $1 }
-/* allows ... and nests */
-eexpr: basic_expr(eexpr,dot_expressions) { $1 }
-/* allows nests but not .... */
-dexpr: basic_expr(eexpr,nest_expressions) { $1 }
-
-top_eexpr:
- eexpr { Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))) }
-
-invalid:
- TInvalid { raise (Semantic_cocci.Semantic "not matchable") }
-
-dot_expressions:
- TEllipsis { Ast0.wrap(Ast0.Edots(P.clt2mcode "..." $1,None)) }
-| nest_expressions { $1 }
-
-/* not clear what whencode would mean, so just drop it */
-nest_expressions:
- TOEllipsis e=expr_dots(TEllipsis) c=TCEllipsis
- { Ast0.wrap(Ast0.NestExpr(P.clt2mcode "<..." $1,
- Ast0.wrap(Ast0.DOTS(e (P.mkedots "..."))),
- P.clt2mcode "...>" c, None, false)) }
-| TPOEllipsis e=expr_dots(TEllipsis) c=TPCEllipsis
- { Ast0.wrap(Ast0.NestExpr(P.clt2mcode "<+..." $1,
- Ast0.wrap(Ast0.DOTS(e (P.mkedots "..."))),
- P.clt2mcode "...+>" c, None, true)) }
-
-//whenexp: TWhen TNotEq w=eexpr TLineEnd { w }
-
-basic_expr(recurser,primary_extra):
- assign_expr(recurser,primary_extra) { $1 }
-
-assign_expr(r,pe):
- cond_expr(r,pe) { $1 }
- | unary_expr(r,pe) TAssign assign_expr_bis
- { let (op,clt) = $2 in
- Ast0.wrap(Ast0.Assignment($1,P.clt2mcode op clt,
- Ast0.set_arg_exp $3,false)) }
- | unary_expr(r,pe) TEq assign_expr_bis
- { Ast0.wrap
- (Ast0.Assignment
- ($1,P.clt2mcode Ast.SimpleAssign $2,Ast0.set_arg_exp $3,false)) }
-
-assign_expr_bis:
- cond_expr(eexpr,dot_expressions) { $1 }
- | unary_expr(eexpr,dot_expressions) TAssign assign_expr_bis
- { let (op,clt) = $2 in
- Ast0.wrap(Ast0.Assignment($1,P.clt2mcode op clt,
- Ast0.set_arg_exp $3,false)) }
- | unary_expr(eexpr,dot_expressions) TEq assign_expr_bis
- { Ast0.wrap
- (Ast0.Assignment
- ($1,P.clt2mcode Ast.SimpleAssign $2,Ast0.set_arg_exp $3,false)) }
-
-cond_expr(r,pe):
- arith_expr(r,pe) { $1 }
- | l=arith_expr(r,pe) w=TWhy t=option(eexpr) dd=TDotDot r=cond_expr(r,pe)
- { Ast0.wrap(Ast0.CondExpr (l, P.clt2mcode "?" w, t,
- P.clt2mcode ":" dd, r)) }
-
-arith_expr(r,pe):
- cast_expr(r,pe) { $1 }
- | arith_expr(r,pe) TMul arith_expr(r,pe)
- { P.arith_op Ast.Mul $1 $2 $3 }
- | arith_expr(r,pe) TDmOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.arith_op op $1 clt $3 }
- | arith_expr(r,pe) TPlus arith_expr(r,pe)
- { P.arith_op Ast.Plus $1 $2 $3 }
- | arith_expr(r,pe) TMinus arith_expr(r,pe)
- { P.arith_op Ast.Minus $1 $2 $3 }
- | arith_expr(r,pe) TShOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.arith_op op $1 clt $3 }
- | arith_expr(r,pe) TLogOp arith_expr(r,pe)
- { let (op,clt) = $2 in P.logic_op op $1 clt $3 }
- | arith_expr(r,pe) TEqEq arith_expr(r,pe)
- { P.logic_op Ast.Eq $1 $2 $3 }
- | arith_expr(r,pe) TNotEq arith_expr(r,pe)
- { P.logic_op Ast.NotEq $1 $2 $3 }
- | arith_expr(r,pe) TAnd arith_expr(r,pe)
- { P.arith_op Ast.And $1 $2 $3 }
- | arith_expr(r,pe) TOr arith_expr(r,pe)
- { P.arith_op Ast.Or $1 $2 $3 }
- | arith_expr(r,pe) TXor arith_expr(r,pe)
- { P.arith_op Ast.Xor $1 $2 $3 }
- | arith_expr(r,pe) TAndLog arith_expr(r,pe)
- { P.logic_op Ast.AndLog $1 $2 $3 }
- | arith_expr(r,pe) TOrLog arith_expr(r,pe)
- { P.logic_op Ast.OrLog $1 $2 $3 }
-
-cast_expr(r,pe):
- unary_expr(r,pe) { $1 }
- | lp=TOPar t=ctype rp=TCPar e=cast_expr(r,pe)
- { Ast0.wrap(Ast0.Cast (P.clt2mcode "(" lp, t,
- P.clt2mcode ")" rp, e)) }
-
-unary_expr(r,pe):
- postfix_expr(r,pe) { $1 }
- | TInc unary_expr(r,pe)
- { Ast0.wrap(Ast0.Infix ($2, P.clt2mcode Ast.Inc $1)) }
- | TDec unary_expr(r,pe)
- { Ast0.wrap(Ast0.Infix ($2, P.clt2mcode Ast.Dec $1)) }
- | unary_op cast_expr(r,pe)
- { let mcode = $1 in Ast0.wrap(Ast0.Unary($2, mcode)) }
- | TBang unary_expr(r,pe)
- { let mcode = P.clt2mcode Ast.Not $1 in
- Ast0.wrap(Ast0.Unary($2, mcode)) }
- | TSizeof unary_expr(r,pe)
- { Ast0.wrap(Ast0.SizeOfExpr (P.clt2mcode "sizeof" $1, $2)) }
- | s=TSizeof lp=TOPar t=ctype rp=TCPar
- { Ast0.wrap(Ast0.SizeOfType (P.clt2mcode "sizeof" s,
- P.clt2mcode "(" lp,t,
- P.clt2mcode ")" rp)) }
-
-unary_op: TAnd { P.clt2mcode Ast.GetRef $1 }
- | TMul { P.clt2mcode Ast.DeRef $1 }
- | TPlus { P.clt2mcode Ast.UnPlus $1 }
- | TMinus { P.clt2mcode Ast.UnMinus $1 }
- | TTilde { P.clt2mcode Ast.Tilde $1 }
-
-postfix_expr(r,pe):
- primary_expr(r,pe) { $1 }
- | postfix_expr(r,pe) TOCro eexpr TCCro
- { Ast0.wrap(Ast0.ArrayAccess ($1,P.clt2mcode "[" $2,$3,
- P.clt2mcode "]" $4)) }
- | postfix_expr(r,pe) TDot ident
- { Ast0.wrap(Ast0.RecordAccess($1, P.clt2mcode "." $2, $3)) }
- | postfix_expr(r,pe) TPtrOp ident
- { Ast0.wrap(Ast0.RecordPtAccess($1, P.clt2mcode "->" $2,
- $3)) }
- | postfix_expr(r,pe) TInc
- { Ast0.wrap(Ast0.Postfix ($1, P.clt2mcode Ast.Inc $2)) }
- | postfix_expr(r,pe) TDec
- { Ast0.wrap(Ast0.Postfix ($1, P.clt2mcode Ast.Dec $2)) }
- | postfix_expr(r,pe) TOPar eexpr_list_option TCPar
- { Ast0.wrap(Ast0.FunCall($1,P.clt2mcode "(" $2,
- $3,
- P.clt2mcode ")" $4)) }
-
-primary_expr(recurser,primary_extra):
- func_ident { Ast0.wrap(Ast0.Ident($1)) }
- | TInt
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Int x) clt)) }
- | TFloat
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Float x) clt)) }
- | TString
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.String x) clt)) }
- | TChar
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Char x) clt)) }
- | TMetaConst
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.CONST,pure)) }
- | TMetaErr
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaErr(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.ANY,pure)) }
- | TMetaIdExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.ID,pure)) }
- | TMetaLocalIdExp
- { let (nm,constraints,pure,ty,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaExpr(P.clt2mcode nm clt,constraints,ty,Ast.LocalID,pure)) }
- | TOPar eexpr TCPar
- { Ast0.wrap(Ast0.Paren(P.clt2mcode "(" $1,$2,
- P.clt2mcode ")" $3)) }
- | TOPar0 midzero_list(recurser,eexpr) TCPar0
- { let (mids,code) = $2 in
- Ast0.wrap(Ast0.DisjExpr(P.clt2mcode "(" $1,
- code, mids,
- P.clt2mcode ")" $3)) }
- | primary_extra { $1 }
-
-expr_dots(dotter):
- r=no_dot_start_end(dexpr,edots_when(dotter,eexpr)) { r }
-
-// used in NEST
-no_dot_start_end(grammar,dotter):
- g=grammar dg=list(pair(dotter,grammar))
- { function dot_builder ->
- g :: (List.concat(List.map (function (d,g) -> [dot_builder d;g]) dg)) }
-
-/*****************************************************************************/
-
-pure_ident:
- TIdent { $1 }
-
-meta_ident:
- TRuleName TDot pure_ident { (Some $1,P.id2name $3) }
-
-pure_ident_or_meta_ident:
- pure_ident { (None,P.id2name $1) }
- | meta_ident { $1 }
- | Tlist { (None,"list") }
- | TError { (None,"error") }
- | TType { (None,"type") }
- | TName { (None,"name") }
-
-pure_ident_or_meta_ident_with_not_eq(not_eq):
- i=pure_ident_or_meta_ident l=loption(not_eq) { (i,l) }
-
-not_eq:
- TNotEq i=pure_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- (* pb: constraints not stored with metavars; too lazy to search for
- them in the pattern *)
- then failwith "constraints not allowed in a generated rule file");
- [Ast0.wrap(Ast0.Id(P.id2mcode i))] }
- | TNotEq TOBrace l=comma_list(pure_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map (function i -> Ast0.wrap(Ast0.Id(P.id2mcode i))) l }
-
-not_eqe:
- TNotEq i=pure_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- [Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i))))] }
- | TNotEq TOBrace l=comma_list(pure_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map
- (function i ->
- Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i)))))
- l }
-
-not_ceq:
- TNotEq i=ident_or_const
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- [i] }
- | TNotEq TOBrace l=comma_list(ident_or_const) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- l }
-
-ident_or_const:
- i=pure_ident { Ast0.wrap(Ast0.Ident(Ast0.wrap(Ast0.Id(P.id2mcode i)))) }
- | TInt
- { let (x,clt) = $1 in
- Ast0.wrap(Ast0.Constant (P.clt2mcode (Ast.Int x) clt)) }
-
-not_pos:
- TNotEq i=meta_ident
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- match i with
- (None,_) -> failwith "constraint must be an inherited variable"
- | (Some rule,name) ->
- let i = (rule,name) in
- P.check_meta(Ast.MetaPosDecl(Ast.NONE,i));
- [i] }
- | TNotEq TOBrace l=comma_list(meta_ident) TCBrace
- { (if !Data.in_iso
- then failwith "constraints not allowed in iso file");
- (if !Data.in_generating
- then failwith "constraints not allowed in a generated rule file");
- List.map
- (function
- (None,_) ->
- failwith "constraint must be an inherited variable"
- | (Some rule,name) ->
- let i = (rule,name) in
- P.check_meta(Ast.MetaPosDecl(Ast.NONE,i));
- i)
- l }
-
-func_ident: pure_ident
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaId
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaFunc
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaFunc(P.clt2mcode nm clt,constraints,pure)) }
- | TMetaLocalFunc
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap
- (Ast0.MetaLocalFunc(P.clt2mcode nm clt,constraints,pure)) }
-
-ident: pure_ident
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaId
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-decl_ident:
- TDeclarerId
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaDeclarer
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-iter_ident:
- TIteratorId
- { Ast0.wrap(Ast0.Id(P.id2mcode $1)) }
- | TMetaIterator
- { let (nm,constraints,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaId(P.clt2mcode nm clt,constraints,pure)) }
-
-typedef_ident:
- pure_ident
- { Ast0.wrap(Ast0.TypeName(P.id2mcode $1)) }
- | TMetaType
- { let (nm,pure,clt) = $1 in
- Ast0.wrap(Ast0.MetaType(P.clt2mcode nm clt,pure)) }
-
-/*****************************************************************************/
-
-decl_list(decl):
- /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-| decl_list_start(decl)
- {let circle x =
- match Ast0.unwrap x with Ast0.Pcircles(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-decl_list_start(decl):
- one_dec(decl) { [$1] }
-| one_dec(decl) TComma decl_list_start(decl)
- { $1::Ast0.wrap(Ast0.PComma(P.clt2mcode "," $2))::$3 }
-| TEllipsis list(comma_decls(TEllipsis,decl))
- { Ast0.wrap(Ast0.Pdots(P.clt2mcode "..." $1))::
- (List.concat(List.map (function x -> x (P.mkpdots "...")) $2)) }
-
-one_dec(decl):
- decl { $1 }
-| TMetaParamList
- { let (nm,lenname,pure,clt) = $1 in
- let nm = P.clt2mcode nm clt in
- let lenname =
- match lenname with
- Some nm -> Some(P.clt2mcode nm clt)
- | None -> None in
- Ast0.wrap(Ast0.MetaParamList(nm,lenname,pure)) }
-
-comma_decls(dotter,decl):
- TComma dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.PComma(P.clt2mcode "," $1));
- dot_builder $2] }
-| TComma one_dec(decl)
- { function dot_builder ->
- [Ast0.wrap(Ast0.PComma(P.clt2mcode "," $1)); $2] }
-
-/* ---------------------------------------------------------------------- */
-
-error_words:
- TError TWords TEq TOCro cl=comma_list(dexpr) TCCro
- { [Ast0.wrap(Ast0.ERRORWORDS(cl))] }
-
-/* ---------------------------------------------------------------------- */
-/* sequences of statements and expressions */
-
-/* There are number of cases that must be considered:
-
-1. Top level:
- Dots and nests allowed at the beginning or end
- Expressions allowed at the beginning or end
- One function allowed, by itself
-2. A function body:
- Dots and nests allowed at the beginning or end
- Expressions not allowed at the beginning or end
- Functions not allowed
-3. The body of a nest:
- Dots and nests not allowed at the beginning or end
- Expressions allowed at the beginning or end
- Functions not allowed
-4. Whencode:
- Dots and nests not allowed at the beginning but allowed at the end
- Expressions allowed at the beginning or end
- Functions not allowed
-
-These are implemented by the rules minus_toplevel_sequence,
-plus_toplevel_sequence, function_body_sequence, nest_body_sequence, and
-when_body_sequence.
-*/
-/* ------------------------------------------------------------------------ */
-/* Minus top level */
-
-/* doesn't allow only ... */
-minus_start:
- fundecl { [Ast0.wrap(Ast0.DECL($1))] }
-| ctype { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Ty($1))))] }
-| top_init { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.TopInit($1))))] }
-| toplevel_seq_startne(toplevel_after_dots_init)
- { List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1 }
-
-toplevel_seq_startne(after_dots_init):
- a=stm_dots_ell b=after_dots_init { a::b }
-| a=stm_dots_nest b=after_dots_init { a::b }
-| a=stm_dots_nest { [a] }
-| expr toplevel_after_exp { (Ast0.wrap(Ast0.Exp($1)))::$2 }
-| decl_statement_expr toplevel_after_stm { $1@$2 }
-
-toplevel_seq_start(after_dots_init):
- stm_dots after_dots_init { $1::$2 }
-| expr toplevel_after_exp { (Ast0.wrap(Ast0.Exp($1)))::$2 }
-| decl_statement_expr toplevel_after_stm { $1@$2 }
-
-toplevel_after_dots_init:
- TNothing toplevel_after_exp {$2}
-| expr toplevel_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-| decl_statement_expr toplevel_after_stm {$1@$2}
-
-toplevel_after_exp:
- /* empty */ {[]}
-| stm_dots toplevel_after_dots {$1::$2}
-
-toplevel_after_dots:
- /* empty */ {[]}
-| TNothing toplevel_after_exp {$2}
-| expr toplevel_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-| decl_statement_expr toplevel_after_stm {$1@$2}
-
-toplevel_after_stm:
- /* empty */ {[]}
-| stm_dots toplevel_after_dots {$1::$2}
-| decl_statement toplevel_after_stm {$1@$2}
-
-top_init:
- TOInit initialize_list TCBrace
- { Ast0.wrap(Ast0.InitList(P.clt2mcode "{" $1,$2,P.clt2mcode "}" $3)) }
-
-/* ------------------------------------------------------------------------ */
-/* Plus top level */
-
-/* does allow only ... also allows multiple top-level functions */
-plus_start:
- ctype { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Ty($1))))] }
-| top_init { [Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.TopInit($1))))] }
-| stm_dots plus_after_dots
- { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-| expr plus_after_exp
- { (Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement_expr plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-plus_after_exp:
- /* empty */ {[]}
-| stm_dots plus_after_dots { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-
-plus_after_dots:
- /* empty */ {[]}
-| TNothing plus_after_exp {$2}
-| expr plus_after_exp
- { (Ast0.wrap(Ast0.OTHER(Ast0.wrap(Ast0.Exp($1)))))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement_expr plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-plus_after_stm:
- /* empty */ {[]}
-| stm_dots plus_after_dots { (Ast0.wrap(Ast0.OTHER($1)))::$2 }
-| fundecl plus_after_stm { Ast0.wrap(Ast0.DECL($1))::$2 }
-| decl_statement plus_after_stm
- { (List.map (function x -> Ast0.wrap(Ast0.OTHER(x))) $1)@$2 }
-
-/* ------------------------------------------------------------------------ */
-/* Function body */
-
-fun_start:
- fun_after_stm { Ast0.wrap(Ast0.DOTS($1)) }
-
-fun_after_stm:
- /* empty */ {[]}
-| stm_dots fun_after_dots {$1::$2}
-| decl_statement fun_after_stm {$1@$2}
-
-fun_after_dots:
- /* empty */ {[]}
-| TNothing fun_after_exp {$2}
-| expr fun_after_exp {Ast0.wrap(Ast0.Exp($1))::$2}
-| decl_statement_expr fun_after_stm {$1@$2}
-
-fun_after_exp:
- stm_dots fun_after_dots {$1::$2}
-
-/* hack to allow mixing statements and expressions in an or */
-fun_after_dots_or:
- /* empty */ {[]}
-| TNothing fun_after_exp_or {$2}
-| expr fun_after_exp_or {Ast0.wrap(Ast0.Exp($1))::$2}
-| decl_statement_expr fun_after_stm {$1@$2}
-
-fun_after_exp_or:
- /* empty */ {[]}
-| stm_dots fun_after_dots {$1::$2}
-
-/* ------------------------------------------------------------------------ */
-/* Nest body */
-
-nest_start:
- nest_after_dots { Ast0.wrap(Ast0.DOTS($1)) }
-
-nest_after_dots:
- decl_statement_expr nest_after_stm {$1@$2}
-| TNothing nest_after_exp {$2}
-| expr nest_after_exp {(Ast0.wrap(Ast0.Exp($1)))::$2}
-
-nest_after_stm:
- /* empty */ {[]}
-| stm_dots nest_after_dots {$1::$2}
-| decl_statement nest_after_stm {$1@$2}
-
-nest_after_exp:
- /* empty */ {[]}
-| stm_dots nest_after_dots {$1::$2}
-
-/* ------------------------------------------------------------------------ */
-/*Whencode*/
-
-when_start:
- expr toplevel_after_exp
- { Ast0.wrap(Ast0.DOTS((Ast0.wrap(Ast0.Exp($1)))::$2)) }
-| decl_statement toplevel_after_stm
- { Ast0.wrap(Ast0.DOTS($1@$2)) }
-
-/* ---------------------------------------------------------------------- */
-
-eexpr_list:
- eexpr_list_start
- {let circle x =
- match Ast0.unwrap x with Ast0.Ecircles(_) -> true | _ -> false in
- let star x =
- match Ast0.unwrap x with Ast0.Estars(_) -> true | _ -> false in
- if List.exists circle $1
- then Ast0.wrap(Ast0.CIRCLES($1))
- else
- if List.exists star $1
- then Ast0.wrap(Ast0.STARS($1))
- else Ast0.wrap(Ast0.DOTS($1)) }
-
-/* arg expr. may contain a type or a explist metavariable */
-aexpr:
- eexpr
- { Ast0.set_arg_exp $1 }
- | TMetaExpList
- { let (nm,lenname,pure,clt) = $1 in
- let nm = P.clt2mcode nm clt in
- let lenname =
- match lenname with
- Some nm -> Some(P.clt2mcode nm clt)
- | None -> None in
- Ast0.wrap(Ast0.MetaExprList(nm,lenname,pure)) }
- | ctype
- { Ast0.set_arg_exp(Ast0.wrap(Ast0.TypeExp($1))) }
-
-eexpr_list_start:
- aexpr { [$1] }
- | aexpr TComma eexpr_list_start
- { $1::Ast0.wrap(Ast0.EComma(P.clt2mcode "," $2))::$3 }
-
-comma_args(dotter):
- c=TComma d=dotter
- { function dot_builder ->
- [Ast0.wrap(Ast0.EComma(P.clt2mcode "," c)); dot_builder d] }
-| TComma aexpr
- { function dot_builder ->
- [Ast0.wrap(Ast0.EComma(P.clt2mcode "," $1)); $2] }
-
-eexpr_list_option: eexpr_list { $1 }
- | /* empty */ { Ast0.wrap(Ast0.DOTS([])) }
-
-/****************************************************************************/
-
-// non-empty lists - drop separator
-comma_list(elem):
- separated_nonempty_list(TComma,elem) { $1 }
-
-midzero_list(elem,aft):
- a=elem b=list(mzl(aft))
- { let (mids,code) = List.split b in (mids,(a::code)) }
-
-mzl(elem):
- a=TMid0 b=elem { (P.clt2mcode "|" a, b) }
-
-edots_when(dotter,when_grammar):
- d=dotter { (d,None) }
- | d=dotter TWhen TNotEq w=when_grammar TLineEnd { (d,Some w) }
-
-whens(when_grammar,simple_when_grammar):
- TWhen TNotEq w=when_grammar TLineEnd { [Ast0.WhenNot w] }
- | TWhen TEq w=simple_when_grammar TLineEnd { [Ast0.WhenAlways w] }
- | TWhen comma_list(any_strict) TLineEnd
- { List.map (function x -> Ast0.WhenModifier(x)) $2 }
- | TWhenTrue TNotEq e = eexpr TLineEnd { [Ast0.WhenNotTrue e] }
- | TWhenFalse TNotEq e = eexpr TLineEnd { [Ast0.WhenNotFalse e] }
-
-any_strict:
- TAny { Ast.WhenAny }
- | TStrict { Ast.WhenStrict }
- | TForall { Ast.WhenForall }
- | TExists { Ast.WhenExists }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-iso_main:
- TIsoExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.ExprTag x) e1 el }
-| TIsoArgExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.ArgExprTag x) e1 el }
-| TIsoTestExpression e1=dexpr el=list(iso(dexpr)) EOF
- { P.iso_adjust (function x -> Ast0.TestExprTag x) e1 el }
-| TIsoStatement s1=single_statement sl=list(iso(single_statement)) EOF
- { P.iso_adjust (function x -> Ast0.StmtTag x) s1 sl }
-| TIsoType t1=ctype tl=list(iso(ctype)) EOF
- { P.iso_adjust (function x -> Ast0.TypeCTag x) t1 tl }
-| TIsoTopLevel e1=nest_start el=list(iso(nest_start)) EOF
- { P.iso_adjust (function x -> Ast0.DotsStmtTag x) e1 el }
-| TIsoDeclaration d1=decl_var dl=list(iso(decl_var)) EOF
- { let check_one = function
- [x] -> x
- | _ ->
- raise
- (Semantic_cocci.Semantic
- "only one variable per declaration in an isomorphism rule") in
- let d1 = check_one d1 in
- let dl =
- List.map
- (function
- Common.Left x -> Common.Left(check_one x)
- | Common.Right x -> Common.Right(check_one x))
- dl in
- P.iso_adjust (function x -> Ast0.DeclTag x) d1 dl }
-
-iso(term):
- TIso t=term { Common.Left t }
- | TRightIso t=term { Common.Right t }
-
-/*****************************************************************************
-*
-*
-*****************************************************************************/
-
-never_used: TPragma { () }
- | TPArob TMetaPos { () }
- | TScriptData { () }
-
-script_meta_main: py=pure_ident TShOp TRuleName TDot cocci=pure_ident TMPtVirg
- { (P.id2name py, ($3, P.id2name cocci)) }
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Format
-module Ast = Ast_cocci
-
-let print_plus_flag = ref true
-let print_minus_flag = ref true
-let print_newlines_disj = ref true
-
-let start_block str =
- force_newline(); print_string " "; open_box 0
-
-let end_block str =
- close_box(); force_newline ()
-
-let print_string_box s = print_string s; open_box 0
-
-
-let print_option = Common.do_option
-let print_between = Common.print_between
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-(* avoid polyvariance problems *)
-let anything : (Ast.anything -> unit) ref = ref (function _ -> ())
-
-let rec print_anything str = function
- [] -> ()
- | stream ->
- start_block();
- print_between force_newline
- (function x ->
- print_string str; open_box 0; print_anything_list x; close_box())
- stream;
- end_block()
-
-and print_anything_list = function
- [] -> ()
- | [x] -> !anything x
- | bef::((aft::_) as rest) ->
- !anything bef;
- let space =
- (match bef with
- Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
- | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_)
- | Ast.Token("if",_) | Ast.Token("while",_) -> true | _ -> false) or
- (match aft with
- Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
- | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_) | Ast.Token("{",_) -> true
- | _ -> false) in
- if space then print_string " ";
- print_anything_list rest
-
-let print_around printer term = function
- Ast.NOTHING -> printer term
- | Ast.BEFORE(bef) -> print_anything "<<< " bef; printer term
- | Ast.AFTER(aft) -> printer term; print_anything ">>> " aft
- | Ast.BEFOREAFTER(bef,aft) ->
- print_anything "<<< " bef; printer term; print_anything ">>> " aft
-
-let print_string_befaft fn x info =
- List.iter (function s -> print_string s; force_newline())
- info.Ast.strbef;
- fn x;
- List.iter (function s -> force_newline(); print_string s)
- info.Ast.straft
-
-let print_meta (r,x) = print_string r; print_string ":"; print_string x
-
-let print_pos = function
- Ast.MetaPos(name,_,_,_,_) ->
- let name = Ast.unwrap_mcode name in
- print_string "@"; print_meta name
- | _ -> ()
-
-let mcode fn = function
- (x, _, Ast.MINUS(_,plus_stream), pos) ->
- if !print_minus_flag
- then print_string (if !Flag.sgrep_mode2 then "*" else "-");
- fn x; print_pos pos;
- if !print_plus_flag
- then print_anything ">>> " plus_stream
- | (x, _, Ast.CONTEXT(_,plus_streams), pos) ->
- if !print_plus_flag
- then
- let fn x = fn x; print_pos pos in
- print_around fn x plus_streams
- else (fn x; print_pos pos)
- | (x, info, Ast.PLUS, pos) ->
- let fn x = fn x; print_pos pos in
- print_string_befaft fn x info
-
-let print_mcodekind = function
- Ast.MINUS(_,plus_stream) ->
- print_string "MINUS";
- print_anything ">>> " plus_stream
- | Ast.CONTEXT(_,plus_streams) ->
- print_around (function _ -> print_string "CONTEXT") () plus_streams
- | Ast.PLUS -> print_string "PLUS"
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots between fn d =
- match Ast.unwrap d with
- Ast.DOTS(l) -> print_between between fn l
- | Ast.CIRCLES(l) -> print_between between fn l
- | Ast.STARS(l) -> print_between between fn l
-
-let nest_dots multi fn f d =
- let mo s = if multi then "<+"^s else "<"^s in
- let mc s = if multi then s^"+>" else s^">" in
- match Ast.unwrap d with
- Ast.DOTS(l) ->
- print_string (mo "..."); f(); start_block();
- print_between force_newline fn l;
- end_block(); print_string (mc "...")
- | Ast.CIRCLES(l) ->
- print_string (mo "ooo"); f(); start_block();
- print_between force_newline fn l;
- end_block(); print_string (mc "ooo")
- | Ast.STARS(l) ->
- print_string (mo "***"); f(); start_block();
- print_between force_newline fn l;
- end_block(); print_string (mc "***")
-
-(* --------------------------------------------------------------------- *)
-
-let print_type keep info = function
- None -> ()
- (* print_string "/* ";
- print_string "keep:"; print_unitary keep;
- print_string " inherited:"; print_bool inherited;
- print_string " */"*)
- | Some ty -> ()
- (*;
- print_string "/* ";
- print_between (function _ -> print_string ", ") Type_cocci.typeC ty;(*
- print_string "keep:"; print_unitary keep;
- print_string " inherited:"; print_bool inherited;*)
- print_string " */"*)
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec ident i =
- match Ast.unwrap i with
- Ast.Id(name) -> mcode print_string name
- | Ast.MetaId(name,_,keep,inherited) -> mcode print_meta name
- | Ast.MetaFunc(name,_,_,_) -> mcode print_meta name
- | Ast.MetaLocalFunc(name,_,_,_) -> mcode print_meta name
- | Ast.OptIdent(id) -> print_string "?"; ident id
- | Ast.UniqueIdent(id) -> print_string "!"; ident id
-
-and print_unitary = function
- Type_cocci.Unitary -> print_string "unitary"
- | Type_cocci.Nonunitary -> print_string "nonunitary"
- | Type_cocci.Saved -> print_string "saved"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let print_disj_list fn l =
- if !print_newlines_disj
- then (force_newline(); print_string "("; force_newline())
- else print_string "(";
- print_between
- (function _ ->
- if !print_newlines_disj
- then (force_newline(); print_string "|"; force_newline())
- else print_string " | ")
- fn l;
- if !print_newlines_disj
- then (force_newline(); print_string ")"; force_newline())
- else print_string ")"
-
-let rec expression e =
- match Ast.unwrap e with
- Ast.Ident(id) -> ident id
- | Ast.Constant(const) -> mcode constant const
- | Ast.FunCall(fn,lp,args,rp) ->
- expression fn; mcode print_string_box lp;
- dots (function _ -> ()) expression args;
- close_box(); mcode print_string rp
- | Ast.Assignment(left,op,right,simple) ->
- expression left; print_string " "; mcode assignOp op;
- print_string " "; expression right
- | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
- expression exp1; print_string " "; mcode print_string why;
- print_option (function e -> print_string " "; expression e) exp2;
- print_string " "; mcode print_string colon; expression exp3
- | Ast.Postfix(exp,op) -> expression exp; mcode fixOp op
- | Ast.Infix(exp,op) -> mcode fixOp op; expression exp
- | Ast.Unary(exp,op) -> mcode unaryOp op; expression exp
- | Ast.Binary(left,op,right) ->
- expression left; print_string " "; mcode binaryOp op; print_string " ";
- expression right
- | Ast.Nested(left,op,right) ->
- expression left; print_string " "; mcode binaryOp op; print_string " ";
- expression right
- | Ast.Paren(lp,exp,rp) ->
- mcode print_string_box lp; expression exp; close_box();
- mcode print_string rp
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- expression exp1; mcode print_string_box lb; expression exp2; close_box();
- mcode print_string rb
- | Ast.RecordAccess(exp,pt,field) ->
- expression exp; mcode print_string pt; ident field
- | Ast.RecordPtAccess(exp,ar,field) ->
- expression exp; mcode print_string ar; ident field
- | Ast.Cast(lp,ty,rp,exp) ->
- mcode print_string_box lp; fullType ty; close_box();
- mcode print_string rp; expression exp
- | Ast.SizeOfExpr(sizeof,exp) ->
- mcode print_string sizeof; expression exp
- | Ast.SizeOfType(sizeof,lp,ty,rp) ->
- mcode print_string sizeof;
- mcode print_string_box lp; fullType ty; close_box();
- mcode print_string rp
- | Ast.TypeExp(ty) -> fullType ty
-
- | Ast.MetaErr(name,_,_,_) -> mcode print_meta name
- | Ast.MetaExpr(name,_,keep,ty,form,inherited) ->
- mcode print_meta name; print_type keep inherited ty
- | Ast.MetaExprList(name,_,_,_) -> mcode print_meta name
- | Ast.EComma(cm) -> mcode print_string cm; print_space()
- | Ast.DisjExpr(exp_list) -> print_disj_list expression exp_list
- | Ast.NestExpr(expr_dots,Some whencode,multi) ->
- nest_dots multi expression
- (function _ -> print_string " when != "; expression whencode)
- expr_dots
- | Ast.NestExpr(expr_dots,None,multi) ->
- nest_dots multi expression (function _ -> ()) expr_dots
- | Ast.Edots(dots,Some whencode)
- | Ast.Ecircles(dots,Some whencode)
- | Ast.Estars(dots,Some whencode) ->
- mcode print_string dots; print_string " when != "; expression whencode
- | Ast.Edots(dots,None)
- | Ast.Ecircles(dots,None)
- | Ast.Estars(dots,None) -> mcode print_string dots
- | Ast.OptExp(exp) -> print_string "?"; expression exp
- | Ast.UniqueExp(exp) -> print_string "!"; expression exp
-
-and unaryOp = function
- Ast.GetRef -> print_string "&"
- | Ast.DeRef -> print_string "*"
- | Ast.UnPlus -> print_string "+"
- | Ast.UnMinus -> print_string "-"
- | Ast.Tilde -> print_string "~"
- | Ast.Not -> print_string "!"
-
-and assignOp = function
- Ast.SimpleAssign -> print_string "="
- | Ast.OpAssign(aop) -> arithOp aop; print_string "="
-
-and fixOp = function
- Ast.Dec -> print_string "--"
- | Ast.Inc -> print_string "++"
-
-and binaryOp = function
- Ast.Arith(aop) -> arithOp aop
- | Ast.Logical(lop) -> logicalOp lop
-
-and arithOp = function
- Ast.Plus -> print_string "+"
- | Ast.Minus -> print_string "-"
- | Ast.Mul -> print_string "*"
- | Ast.Div -> print_string "/"
- | Ast.Mod -> print_string "%"
- | Ast.DecLeft -> print_string "<<"
- | Ast.DecRight -> print_string ">>"
- | Ast.And -> print_string "&"
- | Ast.Or -> print_string "|"
- | Ast.Xor -> print_string "^"
-
-and logicalOp = function
- Ast.Inf -> print_string "<"
- | Ast.Sup -> print_string ">"
- | Ast.InfEq -> print_string "<="
- | Ast.SupEq -> print_string ">="
- | Ast.Eq -> print_string "=="
- | Ast.NotEq -> print_string "!="
- | Ast.AndLog -> print_string "&&"
- | Ast.OrLog -> print_string "||"
-
-and constant = function
- Ast.String(s) -> print_string "\""; print_string s; print_string "\""
- | Ast.Char(s) -> print_string "'"; print_string s; print_string "'"
- | Ast.Int(s) -> print_string s
- | Ast.Float(s) -> print_string s
-
-(* --------------------------------------------------------------------- *)
-(* Declarations *)
-
-and storage = function
- Ast.Static -> print_string "static "
- | Ast.Auto -> print_string "auto "
- | Ast.Register -> print_string "register "
- | Ast.Extern -> print_string "extern "
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and fullType ft =
- match Ast.unwrap ft with
- Ast.Type(cv,ty) ->
- print_option (function x -> mcode const_vol x; print_string " ") cv;
- typeC ty
- | Ast.DisjType(decls) -> print_disj_list fullType decls
- | Ast.OptType(ty) -> print_string "?"; fullType ty
- | Ast.UniqueType(ty) -> print_string "!"; fullType ty
-
-and print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2) fn =
- fullType ty; mcode print_string lp1; mcode print_string star; fn();
- mcode print_string rp1; mcode print_string lp1;
- parameter_list params; mcode print_string rp2
-
-and print_function_type (ty,lp1,params,rp1) fn =
- print_option fullType ty; fn(); mcode print_string lp1;
- parameter_list params; mcode print_string rp1
-
-and print_fninfo = function
- Ast.FStorage(stg) -> mcode storage stg
- | Ast.FType(ty) -> fullType ty
- | Ast.FInline(inline) -> mcode print_string inline; print_string " "
- | Ast.FAttr(attr) -> mcode print_string attr; print_string " "
-
-and typeC ty =
- match Ast.unwrap ty with
- Ast.BaseType(ty,strings) ->
- List.iter (function s -> mcode print_string s; print_string " ") strings
- | Ast.SignedT(sgn,ty) -> mcode sign sgn; print_option typeC ty
- | Ast.Pointer(ty,star) -> fullType ty; mcode print_string star
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> ())
- | Ast.FunctionType (_,ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1) (function _ -> ())
- | Ast.Array(ty,lb,size,rb) ->
- fullType ty; mcode print_string lb; print_option expression size;
- mcode print_string rb
- | Ast.EnumName(kind,name) -> mcode print_string kind; print_string " ";
- ident name
- | Ast.StructUnionName(kind,name) ->
- mcode structUnion kind;
- print_option (function x -> ident x; print_string " ") name
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- fullType ty; mcode print_string lb;
- dots force_newline declaration decls;
- mcode print_string rb
- | Ast.TypeName(name) -> mcode print_string name; print_string " "
- | Ast.MetaType(name,_,_) ->
- mcode print_meta name; print_string " "
-
-and baseType = function
- Ast.VoidType -> print_string "void "
- | Ast.CharType -> print_string "char "
- | Ast.ShortType -> print_string "short "
- | Ast.IntType -> print_string "int "
- | Ast.DoubleType -> print_string "double "
- | Ast.FloatType -> print_string "float "
- | Ast.LongType -> print_string "long "
- | Ast.LongLongType -> print_string "long long "
-
-and structUnion = function
- Ast.Struct -> print_string "struct "
- | Ast.Union -> print_string "union "
-
-and sign = function
- Ast.Signed -> print_string "signed "
- | Ast.Unsigned -> print_string "unsigned "
-
-and const_vol = function
- Ast.Const -> print_string "const"
- | Ast.Volatile -> print_string "volatile"
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and print_named_type ty id =
- match Ast.unwrap ty with
- Ast.Type(None,ty1) ->
- (match Ast.unwrap ty1 with
- Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> print_string " "; ident id)
- | Ast.FunctionType(_,ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1)
- (function _ -> print_string " "; ident id)
- | Ast.Array(ty,lb,size,rb) ->
- let rec loop ty k =
- match Ast.unwrap ty with
- Ast.Array(ty,lb,size,rb) ->
- (match Ast.unwrap ty with
- Ast.Type(None,ty) ->
- loop ty
- (function _ ->
- k ();
- mcode print_string lb;
- print_option expression size;
- mcode print_string rb)
- | _ -> failwith "complex array types not supported")
- | _ -> typeC ty; ident id; k () in
- loop ty1 (function _ -> ())
- | _ -> fullType ty; ident id)
- | _ -> fullType ty; ident id
-
-and declaration d =
- match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- print_option (mcode storage) stg; print_named_type ty id;
- print_string " "; mcode print_string eq;
- print_string " "; initialiser ini; mcode print_string sem
- | Ast.UnInit(stg,ty,id,sem) ->
- print_option (mcode storage) stg; print_named_type ty id;
- mcode print_string sem
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- ident name; mcode print_string_box lp;
- dots (function _ -> ()) expression args;
- close_box(); mcode print_string rp; mcode print_string sem
- | Ast.TyDecl(ty,sem) -> fullType ty; mcode print_string sem
- | Ast.Typedef(stg,ty,id,sem) ->
- mcode print_string stg; print_string " "; fullType ty; typeC id;
- mcode print_string sem
- | Ast.DisjDecl(decls) -> print_disj_list declaration decls
- | Ast.Ddots(dots,Some whencode) ->
- mcode print_string dots; print_string " when != "; declaration whencode
- | Ast.Ddots(dots,None) -> mcode print_string dots
- | Ast.MetaDecl(name,_,_) -> mcode print_meta name
- | Ast.OptDecl(decl) -> print_string "?"; declaration decl
- | Ast.UniqueDecl(decl) -> print_string "!"; declaration decl
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and initialiser i =
- match Ast.unwrap i with
- Ast.InitExpr(exp) -> expression exp
- | Ast.InitList(lb,initlist,rb,whencode) ->
- mcode print_string lb; open_box 0;
- if not (whencode = [])
- then
- (print_string " WHEN != ";
- print_between (function _ -> print_string " v ")
- initialiser whencode;
- force_newline());
- List.iter initialiser initlist; close_box();
- mcode print_string rb
- | Ast.InitGccDotName(dot,name,eq,ini) ->
- mcode print_string dot; ident name; print_string " ";
- mcode print_string eq; print_string " "; initialiser ini
- | Ast.InitGccName(name,eq,ini) ->
- ident name; mcode print_string eq; initialiser ini
- | Ast.InitGccIndex(lb,exp,rb,eq,ini) ->
- mcode print_string lb; expression exp; mcode print_string rb;
- print_string " "; mcode print_string eq; print_string " ";
- initialiser ini
- | Ast.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- mcode print_string lb; expression exp1; mcode print_string dots;
- expression exp2; mcode print_string rb;
- print_string " "; mcode print_string eq; print_string " ";
- initialiser ini
- | Ast.IComma(comma) -> mcode print_string comma; force_newline()
- | Ast.OptIni(ini) -> print_string "?"; initialiser ini
- | Ast.UniqueIni(ini) -> print_string "!"; initialiser ini
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef p =
- match Ast.unwrap p with
- Ast.VoidParam(ty) -> fullType ty
- | Ast.Param(ty,Some id) -> print_named_type ty id
- | Ast.Param(ty,None) -> fullType ty
- | Ast.MetaParam(name,_,_) -> mcode print_meta name
- | Ast.MetaParamList(name,_,_,_) -> mcode print_meta name
- | Ast.PComma(cm) -> mcode print_string cm; print_space()
- | Ast.Pdots(dots) -> mcode print_string dots
- | Ast.Pcircles(dots) -> mcode print_string dots
- | Ast.OptParam(param) -> print_string "?"; parameterTypeDef param
- | Ast.UniqueParam(param) -> print_string "!"; parameterTypeDef param
-
-and parameter_list l = dots (function _ -> ()) parameterTypeDef l
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-let rec rule_elem arity re =
- match Ast.unwrap re with
- Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp) ->
- mcode (function _ -> ()) ((),Ast.no_info,bef,Ast.NoMetaPos);
- print_string arity; List.iter print_fninfo fninfo;
- ident name; mcode print_string_box lp;
- parameter_list params; close_box(); mcode print_string rp;
- print_string " "
- | Ast.Decl(bef,allminus,decl) ->
- mcode (function _ -> ()) ((),Ast.no_info,bef,Ast.NoMetaPos);
- print_string arity;
- declaration decl
- | Ast.SeqStart(brace) ->
- print_string arity; mcode print_string brace;
- if !print_newlines_disj then start_block()
- | Ast.SeqEnd(brace) ->
- if !print_newlines_disj then end_block();
- print_string arity; mcode print_string brace
- | Ast.ExprStatement(exp,sem) ->
- print_string arity; expression exp; mcode print_string sem
- | Ast.IfHeader(iff,lp,exp,rp) ->
- print_string arity;
- mcode print_string iff; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " "
- | Ast.Else(els) ->
- print_string arity; mcode print_string els; print_string " "
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " "
- | Ast.DoHeader(d) ->
- print_string arity; mcode print_string d; print_string " "
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp;
- mcode print_string sem
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- print_string arity;
- mcode print_string fr; mcode print_string_box lp;
- print_option expression e1; mcode print_string sem1;
- print_option expression e2; mcode print_string sem2;
- print_option expression e3; close_box();
- mcode print_string rp; print_string " "
- | Ast.IteratorHeader(nm,lp,args,rp) ->
- print_string arity;
- ident nm; print_string " "; mcode print_string_box lp;
- dots (function _ -> ()) expression args; close_box();
- mcode print_string rp; print_string " "
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- print_string arity;
- mcode print_string switch; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " "
- | Ast.Break(br,sem) ->
- print_string arity; mcode print_string br; mcode print_string sem
- | Ast.Continue(cont,sem) ->
- print_string arity; mcode print_string cont; mcode print_string sem
- | Ast.Label(l,dd) -> ident l; mcode print_string dd
- | Ast.Goto(goto,l,sem) ->
- mcode print_string goto; ident l; mcode print_string sem
- | Ast.Return(ret,sem) ->
- print_string arity; mcode print_string ret; mcode print_string sem
- | Ast.ReturnExpr(ret,exp,sem) ->
- print_string arity; mcode print_string ret; print_string " ";
- expression exp; mcode print_string sem
- | Ast.MetaRuleElem(name,_,_) ->
- print_string arity; mcode print_meta name
- | Ast.MetaStmt(name,_,_,_) ->
- print_string arity; mcode print_meta name
- | Ast.MetaStmtList(name,_,_) ->
- print_string arity; mcode print_meta name
- | Ast.Exp(exp) -> print_string arity; expression exp
- | Ast.TopExp(exp) -> print_string arity; expression exp
- | Ast.Ty(ty) -> print_string arity; fullType ty
- | Ast.TopInit(init) -> initialiser init
- | Ast.Include(inc,s) ->
- mcode print_string inc; print_string " "; mcode inc_file s
- | Ast.DefineHeader(def,id,params) ->
- mcode print_string def; print_string " "; ident id;
- print_define_parameters params
- | Ast.Default(def,colon) ->
- mcode print_string def; mcode print_string colon; print_string " "
- | Ast.Case(case,exp,colon) ->
- mcode print_string case; print_string " "; expression exp;
- mcode print_string colon; print_string " "
- | Ast.DisjRuleElem(res) ->
- print_string arity;
- force_newline(); print_string "("; force_newline();
- print_between
- (function _ -> force_newline();print_string "|"; force_newline())
- (rule_elem arity)
- res;
- force_newline(); print_string ")"
-
-
-and print_define_parameters params =
- match Ast.unwrap params with
- Ast.NoParams -> ()
- | Ast.DParams(lp,params,rp) ->
- mcode print_string lp;
- dots (function _ -> ()) print_define_param params; mcode print_string rp
-
-and print_define_param param =
- match Ast.unwrap param with
- Ast.DParam(id) -> ident id
- | Ast.DPComma(comma) -> mcode print_string comma
- | Ast.DPdots(dots) -> mcode print_string dots
- | Ast.DPcircles(circles) -> mcode print_string circles
- | Ast.OptDParam(dp) -> print_string "?"; print_define_param dp
- | Ast.UniqueDParam(dp) -> print_string "!"; print_define_param dp
-
-and statement arity s =
- match Ast.unwrap s with
- Ast.Seq(lbrace,decls,body,rbrace) ->
- rule_elem arity lbrace;
- dots force_newline (statement arity) decls;
- dots force_newline (statement arity) body;
- rule_elem arity rbrace
- | Ast.IfThen(header,branch,(_,_,_,aft)) ->
- rule_elem arity header; statement arity branch;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
- rule_elem arity header; statement arity branch1; print_string " ";
- rule_elem arity els; statement arity branch2;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.While(header,body,(_,_,_,aft)) ->
- rule_elem arity header; statement arity body;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.Do(header,body,tail) ->
- rule_elem arity header; statement arity body;
- rule_elem arity tail
- | Ast.For(header,body,(_,_,_,aft)) ->
- rule_elem arity header; statement arity body;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.Iterator(header,body,(_,_,_,aft)) ->
- rule_elem arity header; statement arity body;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.Switch(header,lb,cases,rb) ->
- rule_elem arity header; rule_elem arity lb;
- List.iter (function x -> case_line arity x; force_newline()) cases;
- rule_elem arity rb
- | Ast.Atomic(re) -> rule_elem arity re
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- rule_elem arity header; rule_elem arity lbrace;
- dots force_newline (statement arity) decls;
- dots force_newline (statement arity) body;
- rule_elem arity rbrace
- | Ast.Disj([stmt_dots]) ->
- print_string arity;
- dots (function _ -> if !print_newlines_disj then force_newline())
- (statement arity) stmt_dots
- | Ast.Disj(stmt_dots_list) -> (* ignores newline directive for readability *)
- print_string arity;
- force_newline(); print_string "("; force_newline();
- print_between
- (function _ -> force_newline();print_string "|"; force_newline())
- (dots force_newline (statement arity))
- stmt_dots_list;
- force_newline(); print_string ")"
- | Ast.Define(header,body) ->
- rule_elem arity header; print_string " ";
- dots force_newline (statement arity) body
- | Ast.Nest(stmt_dots,whn,multi,_,_) ->
- print_string arity;
- nest_dots multi (statement arity)
- (function _ ->
- open_box 0;
- print_between force_newline
- (whencode (dots force_newline (statement "")) (statement "")) whn;
- close_box(); force_newline())
- stmt_dots
- | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
- print_string arity; mcode print_string d;
- open_box 0;
- print_between force_newline
- (whencode (dots force_newline (statement "")) (statement "")) whn;
- close_box(); force_newline()
- | Ast.OptStm(s) -> statement "?" s
- | Ast.UniqueStm(s) -> statement "!" s
-
-and print_statement_when whencode =
- print_string " WHEN != ";
- open_box 0;
- print_between (function _ -> print_string " &"; force_newline())
- (dots force_newline (statement "")) whencode;
- close_box()
-
-
-and whencode notfn alwaysfn = function
- Ast.WhenNot a ->
- print_string " WHEN != "; open_box 0; notfn a; close_box()
- | Ast.WhenAlways a ->
- print_string " WHEN = "; open_box 0; alwaysfn a; close_box()
- | Ast.WhenModifier x -> print_string " WHEN "; print_when_modif x
- | Ast.WhenNotTrue a ->
- print_string " WHEN != TRUE "; open_box 0; rule_elem "" a; close_box()
- | Ast.WhenNotFalse a ->
- print_string " WHEN != FALSE "; open_box 0; rule_elem "" a; close_box()
-
-and print_when_modif = function
- | Ast.WhenAny -> print_string "ANY"
- | Ast.WhenStrict -> print_string "STRICT"
- | Ast.WhenForall -> print_string "FORALL"
- | Ast.WhenExists -> print_string "EXISTS"
-
-and case_line arity c =
- match Ast.unwrap c with
- Ast.CaseLine(header,code) ->
- rule_elem arity header; print_string " ";
- dots force_newline (statement arity) code
- | Ast.OptCase(case) -> case_line "?" case
-
-(* --------------------------------------------------------------------- *)
-(* CPP code *)
-
-and inc_file = function
- Ast.Local(elems) ->
- print_string "\"";
- print_between (function _ -> print_string "/") inc_elem elems;
- print_string "\""
- | Ast.NonLocal(elems) ->
- print_string "<";
- print_between (function _ -> print_string "/") inc_elem elems;
- print_string ">"
-
-and inc_elem = function
- Ast.IncPath s -> print_string s
- | Ast.IncDots -> print_string "..."
-
-(* for export only *)
-let statement_dots l = dots force_newline (statement "") l
-
-let top_level t =
- match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) ->
- print_string "--- "; mcode print_string old_file; force_newline();
- print_string "+++ "; mcode print_string new_file
- | Ast.DECL(stmt) -> statement "" stmt
- | Ast.CODE(stmt_dots) ->
- dots force_newline (statement "") stmt_dots
- | Ast.ERRORWORDS(exps) ->
- print_string "error words = [";
- print_between (function _ -> print_string ", ") expression exps;
- print_string "]"
-
-let rule =
- print_between (function _ -> force_newline(); force_newline()) top_level
-
-let pp_print_anything x = !anything x
-
-let _ =
- anything := function
- Ast.FullTypeTag(x) -> fullType x
- | Ast.BaseTypeTag(x) -> baseType x
- | Ast.StructUnionTag(x) -> structUnion x
- | Ast.SignTag(x) -> sign x
- | Ast.IdentTag(x) -> ident x
- | Ast.ExpressionTag(x) -> expression x
- | Ast.ConstantTag(x) -> constant x
- | Ast.UnaryOpTag(x) -> unaryOp x
- | Ast.AssignOpTag(x) -> assignOp x
- | Ast.FixOpTag(x) -> fixOp x
- | Ast.BinaryOpTag(x) -> binaryOp x
- | Ast.ArithOpTag(x) -> arithOp x
- | Ast.LogicalOpTag(x) -> logicalOp x
- | Ast.InitTag(x) -> initialiser x
- | Ast.DeclarationTag(x) -> declaration x
- | Ast.StorageTag(x) -> storage x
- | Ast.IncFileTag(x) -> inc_file x
- | Ast.Rule_elemTag(x) -> rule_elem "" x
- | Ast.StatementTag(x) -> statement "" x
- | Ast.CaseLineTag(x) -> case_line "" x
- | Ast.ConstVolTag(x) -> const_vol x
- | Ast.Token(x,Some info) -> print_string_befaft print_string x info
- | Ast.Token(x,None) -> print_string x
- | Ast.Code(x) -> let _ = top_level x in ()
- | Ast.ExprDotsTag(x) -> dots (function _ -> ()) expression x
- | Ast.ParamDotsTag(x) -> parameter_list x
- | Ast.StmtDotsTag(x) -> dots (function _ -> ()) (statement "") x
- | Ast.DeclDotsTag(x) -> dots (function _ -> ()) declaration x
- | Ast.TypeCTag(x) -> typeC x
- | Ast.ParamTag(x) -> parameterTypeDef x
- | Ast.SgrepStartTag(x) -> print_string x
- | Ast.SgrepEndTag(x) -> print_string x
-
-let rec dep in_and = function
- Ast.Dep(s) -> print_string s
- | Ast.AntiDep(s) -> print_string "!"; print_string s
- | Ast.EverDep(s) -> print_string "ever "; print_string s
- | Ast.NeverDep(s) -> print_string "never "; print_string s
- | Ast.AndDep(s1,s2) ->
- let print_and _ = dep true s1; print_string " && "; dep true s2 in
- if in_and
- then print_and ()
- else (print_string "("; print_and(); print_string ")")
- | Ast.OrDep(s1,s2) ->
- let print_or _ = dep false s1; print_string " || "; dep false s2 in
- if not in_and
- then print_or ()
- else (print_string "("; print_or(); print_string ")")
- | Ast.NoDep -> failwith "not possible"
-
-let unparse z =
- match z with
- Ast.ScriptRule (lang,deps,bindings,code) ->
- print_string "@@";
- force_newline();
- print_string ("script:" ^ lang);
- (match deps with
- Ast.NoDep -> ()
- | _ -> print_string " depends on "; dep true deps);
- force_newline();
- print_string "@@";
- force_newline();
- print_string code;
- force_newline()
- | Ast.CocciRule (nm, (deps, drops, exists), x, _, _) ->
- print_string "@@";
- force_newline();
- print_string nm;
- (match deps with
- Ast.NoDep -> ()
- | _ -> print_string " depends on "; dep true deps);
- (*
- print_string "line ";
- print_int (Ast.get_line (List.hd x));
- *)
- force_newline();
- print_string "@@";
- print_newlines_disj := true;
- force_newline();
- force_newline();
- rule x;
- force_newline()
-
-let rule_elem_to_string x =
- print_newlines_disj := true;
- Common.format_to_string (function _ -> rule_elem "" x)
-
-let ident_to_string x =
- print_newlines_disj := true;
- Common.format_to_string (function _ -> ident x)
-
-let unparse_to_string x =
- print_newlines_disj := true;
- Common.format_to_string (function _ -> unparse x)
-
-let print_rule_elem re =
- let nl = !print_newlines_disj in
- print_newlines_disj := false;
- rule_elem "" re;
- print_newlines_disj := nl
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Format
-module Ast = Ast_cocci
-
-let print_plus_flag = ref true
-let print_minus_flag = ref true
-let print_newlines_disj = ref true
-
-let start_block str =
- force_newline(); print_string " "; open_box 0
-
-let end_block str =
- close_box(); force_newline ()
-
-let print_string_box s = print_string s; open_box 0
-
-
-let print_option = Common.do_option
-let print_between = Common.print_between
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-(* avoid polyvariance problems *)
-let anything : (Ast.anything -> unit) ref = ref (function _ -> ())
-
-let rec print_anything str = function
- [] -> ()
- | stream ->
- start_block();
- print_between force_newline
- (function x ->
- print_string str; open_box 0; print_anything_list x; close_box())
- stream;
- end_block()
-
-and print_anything_list = function
- [] -> ()
- | [x] -> !anything x
- | bef::((aft::_) as rest) ->
- !anything bef;
- let space =
- (match bef with
- Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
- | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_)
- | Ast.Token("if",_) | Ast.Token("while",_) -> true | _ -> false) or
- (match aft with
- Ast.Rule_elemTag(_) | Ast.AssignOpTag(_) | Ast.BinaryOpTag(_)
- | Ast.ArithOpTag(_) | Ast.LogicalOpTag(_) | Ast.Token("{",_) -> true
- | _ -> false) in
- if space then print_string " ";
- print_anything_list rest
-
-let print_around printer term = function
- Ast.NOTHING -> printer term
- | Ast.BEFORE(bef) -> print_anything "<<< " bef; printer term
- | Ast.AFTER(aft) -> printer term; print_anything ">>> " aft
- | Ast.BEFOREAFTER(bef,aft) ->
- print_anything "<<< " bef; printer term; print_anything ">>> " aft
-
-let print_string_befaft fn x info =
- List.iter (function s -> print_string s; force_newline())
- info.Ast.strbef;
- fn x;
- List.iter (function s -> force_newline(); print_string s)
- info.Ast.straft
-
-let print_meta (r,x) = print_string r; print_string ":"; print_string x
-
-let print_pos = function
- Ast.MetaPos(name,_,_,_,_) ->
- let name = Ast.unwrap_mcode name in
- print_string "@"; print_meta name
- | _ -> ()
-
-let mcode fn = function
- (x, _, Ast.MINUS(_,plus_stream), pos) ->
- if !print_minus_flag
- then print_string (if !Flag.sgrep_mode2 then "*" else "-");
- fn x; print_pos pos;
- if !print_plus_flag
- then print_anything ">>> " plus_stream
- | (x, _, Ast.CONTEXT(_,plus_streams), pos) ->
- if !print_plus_flag
- then
- let fn x = fn x; print_pos pos in
- print_around fn x plus_streams
- else (fn x; print_pos pos)
- | (x, info, Ast.PLUS, pos) ->
- let fn x = fn x; print_pos pos in
- print_string_befaft fn x info
-
-let print_mcodekind = function
- Ast.MINUS(_,plus_stream) ->
- print_string "MINUS";
- print_anything ">>> " plus_stream
- | Ast.CONTEXT(_,plus_streams) ->
- print_around (function _ -> print_string "CONTEXT") () plus_streams
- | Ast.PLUS -> print_string "PLUS"
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots between fn d =
- match Ast.unwrap d with
- Ast.DOTS(l) -> print_between between fn l
- | Ast.CIRCLES(l) -> print_between between fn l
- | Ast.STARS(l) -> print_between between fn l
-
-let nest_dots multi fn f d =
- let mo s = if multi then "<+"^s else "<"^s in
- let mc s = if multi then s^"+>" else s^">" in
- match Ast.unwrap d with
- Ast.DOTS(l) ->
- print_string (mo "..."); f(); start_block();
- print_between force_newline fn l;
- end_block(); print_string (mc "...")
- | Ast.CIRCLES(l) ->
- print_string (mo "ooo"); f(); start_block();
- print_between force_newline fn l;
- end_block(); print_string (mc "ooo")
- | Ast.STARS(l) ->
- print_string (mo "***"); f(); start_block();
- print_between force_newline fn l;
- end_block(); print_string (mc "***")
-
-(* --------------------------------------------------------------------- *)
-
-let print_type keep info = function
- None -> ()
- (* print_string "/* ";
- print_string "keep:"; print_unitary keep;
- print_string " inherited:"; print_bool inherited;
- print_string " */"*)
- | Some ty -> ()
- (*;
- print_string "/* ";
- print_between (function _ -> print_string ", ") Type_cocci.typeC ty;(*
- print_string "keep:"; print_unitary keep;
- print_string " inherited:"; print_bool inherited;*)
- print_string " */"*)
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec ident i =
- match Ast.unwrap i with
- Ast.Id(name) -> mcode print_string name
- | Ast.MetaId(name,_,keep,inherited) -> mcode print_meta name
- | Ast.MetaFunc(name,_,_,_) -> mcode print_meta name
- | Ast.MetaLocalFunc(name,_,_,_) -> mcode print_meta name
- | Ast.OptIdent(id) -> print_string "?"; ident id
- | Ast.UniqueIdent(id) -> print_string "!"; ident id
-
-and print_unitary = function
- Type_cocci.Unitary -> print_string "unitary"
- | Type_cocci.Nonunitary -> print_string "nonunitary"
- | Type_cocci.Saved -> print_string "saved"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let print_disj_list fn l =
- if !print_newlines_disj
- then (force_newline(); print_string "("; force_newline())
- else print_string "(";
- print_between
- (function _ ->
- if !print_newlines_disj
- then (force_newline(); print_string "|"; force_newline())
- else print_string " | ")
- fn l;
- if !print_newlines_disj
- then (force_newline(); print_string ")"; force_newline())
- else print_string ")"
-
-let rec expression e =
- match Ast.unwrap e with
- Ast.Ident(id) -> ident id
- | Ast.Constant(const) -> mcode constant const
- | Ast.FunCall(fn,lp,args,rp) ->
- expression fn; mcode print_string_box lp;
- dots (function _ -> ()) expression args;
- close_box(); mcode print_string rp
- | Ast.Assignment(left,op,right,simple) ->
- expression left; print_string " "; mcode assignOp op;
- print_string " "; expression right
- | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
- expression exp1; print_string " "; mcode print_string why;
- print_option (function e -> print_string " "; expression e) exp2;
- print_string " "; mcode print_string colon; expression exp3
- | Ast.Postfix(exp,op) -> expression exp; mcode fixOp op
- | Ast.Infix(exp,op) -> mcode fixOp op; expression exp
- | Ast.Unary(exp,op) -> mcode unaryOp op; expression exp
- | Ast.Binary(left,op,right) ->
- expression left; print_string " "; mcode binaryOp op; print_string " ";
- expression right
- | Ast.Nested(left,op,right) ->
- expression left; print_string " "; mcode binaryOp op; print_string " ";
- expression right
- | Ast.Paren(lp,exp,rp) ->
- mcode print_string_box lp; expression exp; close_box();
- mcode print_string rp
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- expression exp1; mcode print_string_box lb; expression exp2; close_box();
- mcode print_string rb
- | Ast.RecordAccess(exp,pt,field) ->
- expression exp; mcode print_string pt; ident field
- | Ast.RecordPtAccess(exp,ar,field) ->
- expression exp; mcode print_string ar; ident field
- | Ast.Cast(lp,ty,rp,exp) ->
- mcode print_string_box lp; fullType ty; close_box();
- mcode print_string rp; expression exp
- | Ast.SizeOfExpr(sizeof,exp) ->
- mcode print_string sizeof; expression exp
- | Ast.SizeOfType(sizeof,lp,ty,rp) ->
- mcode print_string sizeof;
- mcode print_string_box lp; fullType ty; close_box();
- mcode print_string rp
- | Ast.TypeExp(ty) -> fullType ty
-
- | Ast.MetaErr(name,_,_,_) -> mcode print_meta name
- | Ast.MetaExpr(name,_,keep,ty,form,inherited) ->
- mcode print_meta name; print_type keep inherited ty
- | Ast.MetaExprList(name,_,_,_) -> mcode print_meta name
- | Ast.EComma(cm) -> mcode print_string cm; print_space()
- | Ast.DisjExpr(exp_list) -> print_disj_list expression exp_list
- | Ast.NestExpr(expr_dots,Some whencode,multi) ->
- nest_dots multi expression
- (function _ -> print_string " when != "; expression whencode)
- expr_dots
- | Ast.NestExpr(expr_dots,None,multi) ->
- nest_dots multi expression (function _ -> ()) expr_dots
- | Ast.Edots(dots,Some whencode)
- | Ast.Ecircles(dots,Some whencode)
- | Ast.Estars(dots,Some whencode) ->
- mcode print_string dots; print_string " when != "; expression whencode
- | Ast.Edots(dots,None)
- | Ast.Ecircles(dots,None)
- | Ast.Estars(dots,None) -> mcode print_string dots
- | Ast.OptExp(exp) -> print_string "?"; expression exp
- | Ast.UniqueExp(exp) -> print_string "!"; expression exp
-
-and unaryOp = function
- Ast.GetRef -> print_string "&"
- | Ast.DeRef -> print_string "*"
- | Ast.UnPlus -> print_string "+"
- | Ast.UnMinus -> print_string "-"
- | Ast.Tilde -> print_string "~"
- | Ast.Not -> print_string "!"
-
-and assignOp = function
- Ast.SimpleAssign -> print_string "="
- | Ast.OpAssign(aop) -> arithOp aop; print_string "="
-
-and fixOp = function
- Ast.Dec -> print_string "--"
- | Ast.Inc -> print_string "++"
-
-and binaryOp = function
- Ast.Arith(aop) -> arithOp aop
- | Ast.Logical(lop) -> logicalOp lop
-
-and arithOp = function
- Ast.Plus -> print_string "+"
- | Ast.Minus -> print_string "-"
- | Ast.Mul -> print_string "*"
- | Ast.Div -> print_string "/"
- | Ast.Mod -> print_string "%"
- | Ast.DecLeft -> print_string "<<"
- | Ast.DecRight -> print_string ">>"
- | Ast.And -> print_string "&"
- | Ast.Or -> print_string "|"
- | Ast.Xor -> print_string "^"
-
-and logicalOp = function
- Ast.Inf -> print_string "<"
- | Ast.Sup -> print_string ">"
- | Ast.InfEq -> print_string "<="
- | Ast.SupEq -> print_string ">="
- | Ast.Eq -> print_string "=="
- | Ast.NotEq -> print_string "!="
- | Ast.AndLog -> print_string "&&"
- | Ast.OrLog -> print_string "||"
-
-and constant = function
- Ast.String(s) -> print_string "\""; print_string s; print_string "\""
- | Ast.Char(s) -> print_string "'"; print_string s; print_string "'"
- | Ast.Int(s) -> print_string s
- | Ast.Float(s) -> print_string s
-
-(* --------------------------------------------------------------------- *)
-(* Declarations *)
-
-and storage = function
- Ast.Static -> print_string "static "
- | Ast.Auto -> print_string "auto "
- | Ast.Register -> print_string "register "
- | Ast.Extern -> print_string "extern "
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and fullType ft =
- match Ast.unwrap ft with
- Ast.Type(cv,ty) ->
- print_option (function x -> mcode const_vol x; print_string " ") cv;
- typeC ty
- | Ast.DisjType(decls) -> print_disj_list fullType decls
- | Ast.OptType(ty) -> print_string "?"; fullType ty
- | Ast.UniqueType(ty) -> print_string "!"; fullType ty
-
-and print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2) fn =
- fullType ty; mcode print_string lp1; mcode print_string star; fn();
- mcode print_string rp1; mcode print_string lp1;
- parameter_list params; mcode print_string rp2
-
-and print_function_type (ty,lp1,params,rp1) fn =
- print_option fullType ty; fn(); mcode print_string lp1;
- parameter_list params; mcode print_string rp1
-
-and print_fninfo = function
- Ast.FStorage(stg) -> mcode storage stg
- | Ast.FType(ty) -> fullType ty
- | Ast.FInline(inline) -> mcode print_string inline; print_string " "
- | Ast.FAttr(attr) -> mcode print_string attr; print_string " "
-
-and typeC ty =
- match Ast.unwrap ty with
- Ast.BaseType(ty,strings) ->
- List.iter (function s -> mcode print_string s; print_string " ") strings
- | Ast.SignedT(sgn,ty) -> mcode sign sgn; print_option typeC ty
- | Ast.Pointer(ty,star) -> fullType ty; mcode print_string star
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> ())
- | Ast.FunctionType (_,ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1) (function _ -> ())
- | Ast.Array(ty,lb,size,rb) ->
- fullType ty; mcode print_string lb; print_option expression size;
- mcode print_string rb
- | Ast.EnumName(kind,name) -> mcode print_string kind; print_string " ";
- ident name
- | Ast.StructUnionName(kind,name) ->
- mcode structUnion kind;
- print_option (function x -> ident x; print_string " ") name
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- fullType ty; mcode print_string lb;
- dots force_newline declaration decls;
- mcode print_string rb
- | Ast.TypeName(name) -> mcode print_string name; print_string " "
- | Ast.MetaType(name,_,_) ->
- mcode print_meta name; print_string " "
-
-and baseType = function
- Ast.VoidType -> print_string "void "
- | Ast.CharType -> print_string "char "
- | Ast.ShortType -> print_string "short "
- | Ast.IntType -> print_string "int "
- | Ast.DoubleType -> print_string "double "
- | Ast.FloatType -> print_string "float "
- | Ast.LongType -> print_string "long "
- | Ast.LongLongType -> print_string "long long "
-
-and structUnion = function
- Ast.Struct -> print_string "struct "
- | Ast.Union -> print_string "union "
-
-and sign = function
- Ast.Signed -> print_string "signed "
- | Ast.Unsigned -> print_string "unsigned "
-
-and const_vol = function
- Ast.Const -> print_string "const"
- | Ast.Volatile -> print_string "volatile"
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and print_named_type ty id =
- match Ast.unwrap ty with
- Ast.Type(None,ty1) ->
- (match Ast.unwrap ty1 with
- Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> print_string " "; ident id)
- | Ast.FunctionType(_,ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1)
- (function _ -> print_string " "; ident id)
- | Ast.Array(ty,lb,size,rb) ->
- let rec loop ty k =
- match Ast.unwrap ty with
- Ast.Array(ty,lb,size,rb) ->
- (match Ast.unwrap ty with
- Ast.Type(None,ty) ->
- loop ty
- (function _ ->
- k ();
- mcode print_string lb;
- print_option expression size;
- mcode print_string rb)
- | _ -> failwith "complex array types not supported")
- | _ -> typeC ty; ident id; k () in
- loop ty1 (function _ -> ())
- | _ -> fullType ty; ident id)
- | _ -> fullType ty; ident id
-
-and declaration d =
- match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- print_option (mcode storage) stg; print_named_type ty id;
- print_string " "; mcode print_string eq;
- print_string " "; initialiser ini; mcode print_string sem
- | Ast.UnInit(stg,ty,id,sem) ->
- print_option (mcode storage) stg; print_named_type ty id;
- mcode print_string sem
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- ident name; mcode print_string_box lp;
- dots (function _ -> ()) expression args;
- close_box(); mcode print_string rp; mcode print_string sem
- | Ast.TyDecl(ty,sem) -> fullType ty; mcode print_string sem
- | Ast.Typedef(stg,ty,id,sem) ->
- mcode print_string stg; print_string " "; fullType ty; typeC id;
- mcode print_string sem
- | Ast.DisjDecl(decls) -> print_disj_list declaration decls
- | Ast.Ddots(dots,Some whencode) ->
- mcode print_string dots; print_string " when != "; declaration whencode
- | Ast.Ddots(dots,None) -> mcode print_string dots
- | Ast.MetaDecl(name,_,_) -> mcode print_meta name
- | Ast.OptDecl(decl) -> print_string "?"; declaration decl
- | Ast.UniqueDecl(decl) -> print_string "!"; declaration decl
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and initialiser i =
- match Ast.unwrap i with
- Ast.MetaInit(name,_,_) ->
- mcode print_meta name; print_string " "
- | Ast.InitExpr(exp) -> expression exp
- | Ast.InitList(lb,initlist,rb,whencode) ->
- mcode print_string lb; open_box 0;
- if not (whencode = [])
- then
- (print_string " WHEN != ";
- print_between (function _ -> print_string " v ")
- initialiser whencode;
- force_newline());
- List.iter initialiser initlist; close_box();
- mcode print_string rb
- | Ast.InitGccExt(designators,eq,ini) ->
- List.iter designator designators; print_string " ";
- mcode print_string eq; print_string " "; initialiser ini
- | Ast.InitGccName(name,eq,ini) ->
- ident name; mcode print_string eq; initialiser ini
- | Ast.IComma(comma) -> mcode print_string comma; force_newline()
- | Ast.OptIni(ini) -> print_string "?"; initialiser ini
- | Ast.UniqueIni(ini) -> print_string "!"; initialiser ini
-
-and designator = function
- Ast.DesignatorField(dot,id) -> mcode print_string dot; ident id
- | Ast.DesignatorIndex(lb,exp,rb) ->
- mcode print_string lb; expression exp; mcode print_string rb
- | Ast.DesignatorRange(lb,min,dots,max,rb) ->
- mcode print_string lb; expression min; mcode print_string dots;
- expression max; mcode print_string rb
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef p =
- match Ast.unwrap p with
- Ast.VoidParam(ty) -> fullType ty
- | Ast.Param(ty,Some id) -> print_named_type ty id
- | Ast.Param(ty,None) -> fullType ty
- | Ast.MetaParam(name,_,_) -> mcode print_meta name
- | Ast.MetaParamList(name,_,_,_) -> mcode print_meta name
- | Ast.PComma(cm) -> mcode print_string cm; print_space()
- | Ast.Pdots(dots) -> mcode print_string dots
- | Ast.Pcircles(dots) -> mcode print_string dots
- | Ast.OptParam(param) -> print_string "?"; parameterTypeDef param
- | Ast.UniqueParam(param) -> print_string "!"; parameterTypeDef param
-
-and parameter_list l = dots (function _ -> ()) parameterTypeDef l
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-let rec rule_elem arity re =
- match Ast.unwrap re with
- Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp) ->
- mcode (function _ -> ()) ((),Ast.no_info,bef,Ast.NoMetaPos);
- print_string arity; List.iter print_fninfo fninfo;
- ident name; mcode print_string_box lp;
- parameter_list params; close_box(); mcode print_string rp;
- print_string " "
- | Ast.Decl(bef,allminus,decl) ->
- mcode (function _ -> ()) ((),Ast.no_info,bef,Ast.NoMetaPos);
- print_string arity;
- declaration decl
- | Ast.SeqStart(brace) ->
- print_string arity; mcode print_string brace;
- if !print_newlines_disj then start_block()
- | Ast.SeqEnd(brace) ->
- if !print_newlines_disj then end_block();
- print_string arity; mcode print_string brace
- | Ast.ExprStatement(exp,sem) ->
- print_string arity; expression exp; mcode print_string sem
- | Ast.IfHeader(iff,lp,exp,rp) ->
- print_string arity;
- mcode print_string iff; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " "
- | Ast.Else(els) ->
- print_string arity; mcode print_string els; print_string " "
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " "
- | Ast.DoHeader(d) ->
- print_string arity; mcode print_string d; print_string " "
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp;
- mcode print_string sem
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- print_string arity;
- mcode print_string fr; mcode print_string_box lp;
- print_option expression e1; mcode print_string sem1;
- print_option expression e2; mcode print_string sem2;
- print_option expression e3; close_box();
- mcode print_string rp; print_string " "
- | Ast.IteratorHeader(nm,lp,args,rp) ->
- print_string arity;
- ident nm; print_string " "; mcode print_string_box lp;
- dots (function _ -> ()) expression args; close_box();
- mcode print_string rp; print_string " "
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- print_string arity;
- mcode print_string switch; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " "
- | Ast.Break(br,sem) ->
- print_string arity; mcode print_string br; mcode print_string sem
- | Ast.Continue(cont,sem) ->
- print_string arity; mcode print_string cont; mcode print_string sem
- | Ast.Label(l,dd) -> ident l; mcode print_string dd
- | Ast.Goto(goto,l,sem) ->
- mcode print_string goto; ident l; mcode print_string sem
- | Ast.Return(ret,sem) ->
- print_string arity; mcode print_string ret; mcode print_string sem
- | Ast.ReturnExpr(ret,exp,sem) ->
- print_string arity; mcode print_string ret; print_string " ";
- expression exp; mcode print_string sem
- | Ast.MetaRuleElem(name,_,_) ->
- print_string arity; mcode print_meta name
- | Ast.MetaStmt(name,_,_,_) ->
- print_string arity; mcode print_meta name
- | Ast.MetaStmtList(name,_,_) ->
- print_string arity; mcode print_meta name
- | Ast.Exp(exp) -> print_string arity; expression exp
- | Ast.TopExp(exp) -> print_string arity; expression exp
- | Ast.Ty(ty) -> print_string arity; fullType ty
- | Ast.TopInit(init) -> initialiser init
- | Ast.Include(inc,s) ->
- mcode print_string inc; print_string " "; mcode inc_file s
- | Ast.DefineHeader(def,id,params) ->
- mcode print_string def; print_string " "; ident id;
- print_define_parameters params
- | Ast.Default(def,colon) ->
- mcode print_string def; mcode print_string colon; print_string " "
- | Ast.Case(case,exp,colon) ->
- mcode print_string case; print_string " "; expression exp;
- mcode print_string colon; print_string " "
- | Ast.DisjRuleElem(res) ->
- print_string arity;
- force_newline(); print_string "("; force_newline();
- print_between
- (function _ -> force_newline();print_string "|"; force_newline())
- (rule_elem arity)
- res;
- force_newline(); print_string ")"
-
-
-and print_define_parameters params =
- match Ast.unwrap params with
- Ast.NoParams -> ()
- | Ast.DParams(lp,params,rp) ->
- mcode print_string lp;
- dots (function _ -> ()) print_define_param params; mcode print_string rp
-
-and print_define_param param =
- match Ast.unwrap param with
- Ast.DParam(id) -> ident id
- | Ast.DPComma(comma) -> mcode print_string comma
- | Ast.DPdots(dots) -> mcode print_string dots
- | Ast.DPcircles(circles) -> mcode print_string circles
- | Ast.OptDParam(dp) -> print_string "?"; print_define_param dp
- | Ast.UniqueDParam(dp) -> print_string "!"; print_define_param dp
-
-and statement arity s =
- match Ast.unwrap s with
- Ast.Seq(lbrace,decls,body,rbrace) ->
- rule_elem arity lbrace;
- dots force_newline (statement arity) decls;
- dots force_newline (statement arity) body;
- rule_elem arity rbrace
- | Ast.IfThen(header,branch,(_,_,_,aft)) ->
- rule_elem arity header; statement arity branch;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
- rule_elem arity header; statement arity branch1; print_string " ";
- rule_elem arity els; statement arity branch2;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.While(header,body,(_,_,_,aft)) ->
- rule_elem arity header; statement arity body;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.Do(header,body,tail) ->
- rule_elem arity header; statement arity body;
- rule_elem arity tail
- | Ast.For(header,body,(_,_,_,aft)) ->
- rule_elem arity header; statement arity body;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.Iterator(header,body,(_,_,_,aft)) ->
- rule_elem arity header; statement arity body;
- mcode (function _ -> ()) ((),Ast.no_info,aft,Ast.NoMetaPos)
- | Ast.Switch(header,lb,cases,rb) ->
- rule_elem arity header; rule_elem arity lb;
- List.iter (function x -> case_line arity x; force_newline()) cases;
- rule_elem arity rb
- | Ast.Atomic(re) -> rule_elem arity re
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- rule_elem arity header; rule_elem arity lbrace;
- dots force_newline (statement arity) decls;
- dots force_newline (statement arity) body;
- rule_elem arity rbrace
- | Ast.Disj([stmt_dots]) ->
- print_string arity;
- dots (function _ -> if !print_newlines_disj then force_newline())
- (statement arity) stmt_dots
- | Ast.Disj(stmt_dots_list) -> (* ignores newline directive for readability *)
- print_string arity;
- force_newline(); print_string "("; force_newline();
- print_between
- (function _ -> force_newline();print_string "|"; force_newline())
- (dots force_newline (statement arity))
- stmt_dots_list;
- force_newline(); print_string ")"
- | Ast.Define(header,body) ->
- rule_elem arity header; print_string " ";
- dots force_newline (statement arity) body
- | Ast.Nest(stmt_dots,whn,multi,_,_) ->
- print_string arity;
- nest_dots multi (statement arity)
- (function _ ->
- open_box 0;
- print_between force_newline
- (whencode (dots force_newline (statement "")) (statement "")) whn;
- close_box(); force_newline())
- stmt_dots
- | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
- print_string arity; mcode print_string d;
- open_box 0;
- print_between force_newline
- (whencode (dots force_newline (statement "")) (statement "")) whn;
- close_box(); force_newline()
- | Ast.OptStm(s) -> statement "?" s
- | Ast.UniqueStm(s) -> statement "!" s
-
-and print_statement_when whencode =
- print_string " WHEN != ";
- open_box 0;
- print_between (function _ -> print_string " &"; force_newline())
- (dots force_newline (statement "")) whencode;
- close_box()
-
-
-and whencode notfn alwaysfn = function
- Ast.WhenNot a ->
- print_string " WHEN != "; open_box 0; notfn a; close_box()
- | Ast.WhenAlways a ->
- print_string " WHEN = "; open_box 0; alwaysfn a; close_box()
- | Ast.WhenModifier x -> print_string " WHEN "; print_when_modif x
- | Ast.WhenNotTrue a ->
- print_string " WHEN != TRUE "; open_box 0; rule_elem "" a; close_box()
- | Ast.WhenNotFalse a ->
- print_string " WHEN != FALSE "; open_box 0; rule_elem "" a; close_box()
-
-and print_when_modif = function
- | Ast.WhenAny -> print_string "ANY"
- | Ast.WhenStrict -> print_string "STRICT"
- | Ast.WhenForall -> print_string "FORALL"
- | Ast.WhenExists -> print_string "EXISTS"
-
-and case_line arity c =
- match Ast.unwrap c with
- Ast.CaseLine(header,code) ->
- rule_elem arity header; print_string " ";
- dots force_newline (statement arity) code
- | Ast.OptCase(case) -> case_line "?" case
-
-(* --------------------------------------------------------------------- *)
-(* CPP code *)
-
-and inc_file = function
- Ast.Local(elems) ->
- print_string "\"";
- print_between (function _ -> print_string "/") inc_elem elems;
- print_string "\""
- | Ast.NonLocal(elems) ->
- print_string "<";
- print_between (function _ -> print_string "/") inc_elem elems;
- print_string ">"
-
-and inc_elem = function
- Ast.IncPath s -> print_string s
- | Ast.IncDots -> print_string "..."
-
-(* for export only *)
-let statement_dots l = dots force_newline (statement "") l
-
-let top_level t =
- match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) ->
- print_string "--- "; mcode print_string old_file; force_newline();
- print_string "+++ "; mcode print_string new_file
- | Ast.DECL(stmt) -> statement "" stmt
- | Ast.CODE(stmt_dots) ->
- dots force_newline (statement "") stmt_dots
- | Ast.ERRORWORDS(exps) ->
- print_string "error words = [";
- print_between (function _ -> print_string ", ") expression exps;
- print_string "]"
-
-let rule =
- print_between (function _ -> force_newline(); force_newline()) top_level
-
-let pp_print_anything x = !anything x
-
-let _ =
- anything := function
- Ast.FullTypeTag(x) -> fullType x
- | Ast.BaseTypeTag(x) -> baseType x
- | Ast.StructUnionTag(x) -> structUnion x
- | Ast.SignTag(x) -> sign x
- | Ast.IdentTag(x) -> ident x
- | Ast.ExpressionTag(x) -> expression x
- | Ast.ConstantTag(x) -> constant x
- | Ast.UnaryOpTag(x) -> unaryOp x
- | Ast.AssignOpTag(x) -> assignOp x
- | Ast.FixOpTag(x) -> fixOp x
- | Ast.BinaryOpTag(x) -> binaryOp x
- | Ast.ArithOpTag(x) -> arithOp x
- | Ast.LogicalOpTag(x) -> logicalOp x
- | Ast.InitTag(x) -> initialiser x
- | Ast.DeclarationTag(x) -> declaration x
- | Ast.StorageTag(x) -> storage x
- | Ast.IncFileTag(x) -> inc_file x
- | Ast.Rule_elemTag(x) -> rule_elem "" x
- | Ast.StatementTag(x) -> statement "" x
- | Ast.CaseLineTag(x) -> case_line "" x
- | Ast.ConstVolTag(x) -> const_vol x
- | Ast.Token(x,Some info) -> print_string_befaft print_string x info
- | Ast.Token(x,None) -> print_string x
- | Ast.Code(x) -> let _ = top_level x in ()
- | Ast.ExprDotsTag(x) -> dots (function _ -> ()) expression x
- | Ast.ParamDotsTag(x) -> parameter_list x
- | Ast.StmtDotsTag(x) -> dots (function _ -> ()) (statement "") x
- | Ast.DeclDotsTag(x) -> dots (function _ -> ()) declaration x
- | Ast.TypeCTag(x) -> typeC x
- | Ast.ParamTag(x) -> parameterTypeDef x
- | Ast.SgrepStartTag(x) -> print_string x
- | Ast.SgrepEndTag(x) -> print_string x
-
-let rec dep in_and = function
- Ast.Dep(s) -> print_string s
- | Ast.AntiDep(s) -> print_string "!"; print_string s
- | Ast.EverDep(s) -> print_string "ever "; print_string s
- | Ast.NeverDep(s) -> print_string "never "; print_string s
- | Ast.AndDep(s1,s2) ->
- let print_and _ = dep true s1; print_string " && "; dep true s2 in
- if in_and
- then print_and ()
- else (print_string "("; print_and(); print_string ")")
- | Ast.OrDep(s1,s2) ->
- let print_or _ = dep false s1; print_string " || "; dep false s2 in
- if not in_and
- then print_or ()
- else (print_string "("; print_or(); print_string ")")
- | Ast.NoDep -> failwith "not possible"
-
-let unparse z =
- match z with
- Ast.ScriptRule (lang,deps,bindings,code) ->
- print_string "@@";
- force_newline();
- print_string ("script:" ^ lang);
- (match deps with
- Ast.NoDep -> ()
- | _ -> print_string " depends on "; dep true deps);
- force_newline();
- print_string "@@";
- force_newline();
- print_string code;
- force_newline()
- | Ast.CocciRule (nm, (deps, drops, exists), x, _, _) ->
- print_string "@@";
- force_newline();
- print_string nm;
- (match deps with
- Ast.NoDep -> ()
- | _ -> print_string " depends on "; dep true deps);
- (*
- print_string "line ";
- print_int (Ast.get_line (List.hd x));
- *)
- force_newline();
- print_string "@@";
- print_newlines_disj := true;
- force_newline();
- force_newline();
- rule x;
- force_newline()
-
-let rule_elem_to_string x =
- print_newlines_disj := true;
- Common.format_to_string (function _ -> rule_elem "" x)
-
-let ident_to_string x =
- print_newlines_disj := true;
- Common.format_to_string (function _ -> ident x)
-
-let unparse_to_string x =
- print_newlines_disj := true;
- Common.format_to_string (function _ -> unparse x)
-
-let print_rule_elem re =
- let nl = !print_newlines_disj in
- print_newlines_disj := false;
- rule_elem "" re;
- print_newlines_disj := nl
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module T = Type_cocci
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-module V0 = Visitor_ast0
-
-(* Type inference:
-Just propagates information based on declarations. Could try to infer
-more precise information about expression metavariables, but not sure it is
-worth it. The most obvious goal is to distinguish between test expressions
-that have pointer, integer, and boolean type when matching isomorphisms,
-but perhaps other needs will become apparent. *)
-
-(* "functions" that return a boolean value *)
-let bool_functions = ["likely";"unlikely"]
-
-let err wrapped ty s =
- T.typeC ty; Format.print_newline();
- failwith (Printf.sprintf "line %d: %s" (Ast0.get_line wrapped) s)
-
-type id = Id of string | Meta of (string * string)
-
-let int_type = T.BaseType(T.IntType)
-let bool_type = T.BaseType(T.BoolType)
-let char_type = T.BaseType(T.CharType)
-let float_type = T.BaseType(T.FloatType)
-
-let rec lub_type t1 t2 =
- match (t1,t2) with
- (None,None) -> None
- | (None,Some t) -> t2
- | (Some t,None) -> t1
- | (Some t1,Some t2) ->
- let rec loop = function
- (T.Unknown,t2) -> t2
- | (t1,T.Unknown) -> t1
- | (T.ConstVol(cv1,ty1),T.ConstVol(cv2,ty2)) when cv1 = cv2 ->
- T.ConstVol(cv1,loop(ty1,ty2))
-
- (* pad: in pointer arithmetic, as in ptr+1, the lub must be ptr *)
- | (T.Pointer(ty1),T.Pointer(ty2)) ->
- T.Pointer(loop(ty1,ty2))
- | (ty1,T.Pointer(ty2)) -> T.Pointer(ty2)
- | (T.Pointer(ty1),ty2) -> T.Pointer(ty1)
-
- | (T.Array(ty1),T.Array(ty2)) -> T.Array(loop(ty1,ty2))
- | (T.TypeName(s1),t2) -> t2
- | (t1,T.TypeName(s1)) -> t1
- | (t1,_) -> t1 in (* arbitrarily pick the first, assume type correct *)
- Some (loop (t1,t2))
-
-let lub_envs envs =
- List.fold_left
- (function acc ->
- function env ->
- List.fold_left
- (function acc ->
- function (var,ty) ->
- let (relevant,irrelevant) =
- List.partition (function (x,_) -> x = var) acc in
- match relevant with
- [] -> (var,ty)::acc
- | [(x,ty1)] ->
- (match lub_type (Some ty) (Some ty1) with
- Some new_ty -> (var,new_ty)::irrelevant
- | None -> irrelevant)
- | _ -> failwith "bad type environment")
- acc env)
- [] envs
-
-let rec propagate_types env =
- let option_default = None in
- let bind x y = option_default in (* no generic way of combining types *)
-
- let mcode x = option_default in
-
- let ident r k i =
- match Ast0.unwrap i with
- Ast0.Id(id) ->
- (try Some(List.assoc (Id(Ast0.unwrap_mcode id)) env)
- with Not_found -> None)
- | Ast0.MetaId(id,_,_) ->
- (try Some(List.assoc (Meta(Ast0.unwrap_mcode id)) env)
- with Not_found -> None)
- | _ -> k i in
-
- let strip_cv = function
- Some (T.ConstVol(_,t)) -> Some t
- | t -> t in
-
- (* types that might be integer types. should char be allowed? *)
- let rec is_int_type = function
- T.BaseType(T.IntType)
- | T.BaseType(T.LongType)
- | T.BaseType(T.ShortType)
- | T.MetaType(_,_,_)
- | T.TypeName _
- | T.SignedT(_,None) -> true
- | T.SignedT(_,Some ty) -> is_int_type ty
- | _ -> false in
-
- let expression r k e =
- let res = k e in
- let ty =
- match Ast0.unwrap e with
- (* pad: the type of id is set in the ident visitor *)
- Ast0.Ident(id) -> Ast0.set_type e res; res
- | Ast0.Constant(const) ->
- (match Ast0.unwrap_mcode const with
- Ast.String(_) -> Some (T.Pointer(char_type))
- | Ast.Char(_) -> Some (char_type)
- | Ast.Int(_) -> Some (int_type)
- | Ast.Float(_) -> Some (float_type))
- (* pad: note that in C can do either ptr(...) or ( *ptr)(...)
- * so I am not sure this code is enough.
- *)
- | Ast0.FunCall(fn,lp,args,rp) ->
- (match Ast0.get_type fn with
- Some (T.FunctionPointer(ty)) -> Some ty
- | _ ->
- (match Ast0.unwrap fn with
- Ast0.Ident(id) ->
- (match Ast0.unwrap id with
- Ast0.Id(id) ->
- if List.mem (Ast0.unwrap_mcode id) bool_functions
- then Some(bool_type)
- else None
- | _ -> None)
- | _ -> None))
- | Ast0.Assignment(exp1,op,exp2,_) ->
- let ty = lub_type (Ast0.get_type exp1) (Ast0.get_type exp2) in
- Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty
- | Ast0.CondExpr(exp1,why,Some exp2,colon,exp3) ->
- let ty = lub_type (Ast0.get_type exp2) (Ast0.get_type exp3) in
- Ast0.set_type exp2 ty; Ast0.set_type exp3 ty; ty
- | Ast0.CondExpr(exp1,why,None,colon,exp3) -> Ast0.get_type exp3
- | Ast0.Postfix(exp,op) | Ast0.Infix(exp,op) -> (* op is dec or inc *)
- Ast0.get_type exp
- | Ast0.Unary(exp,op) ->
- (match Ast0.unwrap_mcode op with
- Ast.GetRef ->
- (match Ast0.get_type exp with
- None -> Some (T.Pointer(T.Unknown))
- | Some t -> Some (T.Pointer(t)))
- | Ast.DeRef ->
- (match Ast0.get_type exp with
- Some (T.Pointer(t)) -> Some t
- | _ -> None)
- | Ast.UnPlus -> Ast0.get_type exp
- | Ast.UnMinus -> Ast0.get_type exp
- | Ast.Tilde -> Ast0.get_type exp
- | Ast.Not -> Some(bool_type))
- | Ast0.Nested(exp1,op,exp2) -> failwith "nested in type inf not possible"
- | Ast0.Binary(exp1,op,exp2) ->
- let ty1 = Ast0.get_type exp1 in
- let ty2 = Ast0.get_type exp2 in
- let same_type = function
- (None,None) -> Some (int_type)
-
- (* pad: pointer arithmetic handling as in ptr+1 *)
- | (Some (T.Pointer ty1),Some ty2) when is_int_type ty2 ->
- Some (T.Pointer ty1)
- | (Some ty1,Some (T.Pointer ty2)) when is_int_type ty1 ->
- Some (T.Pointer ty2)
-
- | (t1,t2) ->
- let ty = lub_type t1 t2 in
- Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty in
- (match Ast0.unwrap_mcode op with
- Ast.Arith(op) -> same_type (ty1, ty2)
- | Ast.Logical(op) ->
- let ty = lub_type ty1 ty2 in
- Ast0.set_type exp1 ty; Ast0.set_type exp2 ty;
- Some(bool_type))
- | Ast0.Paren(lp,exp,rp) -> Ast0.get_type exp
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- (match strip_cv (Ast0.get_type exp2) with
- None -> Ast0.set_type exp2 (Some(int_type))
- | Some(ty) when is_int_type ty -> ()
- | Some ty -> err exp2 ty "bad type for an array index");
- (match strip_cv (Ast0.get_type exp1) with
- None -> None
- | Some (T.Array(ty)) -> Some ty
- | Some (T.Pointer(ty)) -> Some ty
- | Some (T.MetaType(_,_,_)) -> None
- | Some x -> err exp1 x "ill-typed array reference")
- (* pad: should handle structure one day and look 'field' in environment *)
- | Ast0.RecordAccess(exp,pt,field) ->
- (match strip_cv (Ast0.get_type exp) with
- None -> None
- | Some (T.StructUnionName(_,_,_)) -> None
- | Some (T.TypeName(_)) -> None
- | Some (T.MetaType(_,_,_)) -> None
- | Some x -> err exp x "non-structure type in field ref")
- | Ast0.RecordPtAccess(exp,ar,field) ->
- (match strip_cv (Ast0.get_type exp) with
- None -> None
- | Some (T.Pointer(t)) ->
- (match strip_cv (Some t) with
- | Some (T.Unknown) -> None
- | Some (T.MetaType(_,_,_)) -> None
- | Some (T.TypeName(_)) -> None
- | Some (T.StructUnionName(_,_,_)) -> None
- | Some x ->
- err exp (T.Pointer(t))
- "non-structure pointer type in field ref"
- | _ -> failwith "not possible")
- | Some (T.MetaType(_,_,_)) -> None
- | Some (T.TypeName(_)) -> None
- | Some x -> err exp x "non-structure pointer type in field ref")
- | Ast0.Cast(lp,ty,rp,exp) -> Some(Ast0.ast0_type_to_type ty)
- | Ast0.SizeOfExpr(szf,exp) -> Some(int_type)
- | Ast0.SizeOfType(szf,lp,ty,rp) -> Some(int_type)
- | Ast0.TypeExp(ty) -> None
- | Ast0.MetaErr(name,_,_) -> None
- | Ast0.MetaExpr(name,_,Some [ty],_,_) -> Some ty
- | Ast0.MetaExpr(name,_,ty,_,_) -> None
- | Ast0.MetaExprList(name,_,_) -> None
- | Ast0.EComma(cm) -> None
- | Ast0.DisjExpr(_,exp_list,_,_) ->
- let types = List.map Ast0.get_type exp_list in
- let combined = List.fold_left lub_type None types in
- (match combined with
- None -> None
- | Some t ->
- List.iter (function e -> Ast0.set_type e (Some t)) exp_list;
- Some t)
- | Ast0.NestExpr(starter,expr_dots,ender,None,multi) ->
- let _ = r.V0.combiner_expression_dots expr_dots in None
- | Ast0.NestExpr(starter,expr_dots,ender,Some e,multi) ->
- let _ = r.V0.combiner_expression_dots expr_dots in
- let _ = r.V0.combiner_expression e in None
- | Ast0.Edots(_,None) | Ast0.Ecircles(_,None) | Ast0.Estars(_,None) ->
- None
- | Ast0.Edots(_,Some e) | Ast0.Ecircles(_,Some e)
- | Ast0.Estars(_,Some e) ->
- let _ = r.V0.combiner_expression e in None
- | Ast0.OptExp(exp) -> Ast0.get_type exp
- | Ast0.UniqueExp(exp) -> Ast0.get_type exp in
- Ast0.set_type e ty;
- ty in
-
- let donothing r k e = k e in
-
- let rec strip id =
- match Ast0.unwrap id with
- Ast0.Id(name) -> Id(Ast0.unwrap_mcode name)
- | Ast0.MetaId(name,_,_) -> Meta(Ast0.unwrap_mcode name)
- | Ast0.MetaFunc(name,_,_) -> Meta(Ast0.unwrap_mcode name)
- | Ast0.MetaLocalFunc(name,_,_) -> Meta(Ast0.unwrap_mcode name)
- | Ast0.OptIdent(id) -> strip id
- | Ast0.UniqueIdent(id) -> strip id in
-
- let process_whencode notfn allfn exp = function
- Ast0.WhenNot(x) -> let _ = notfn x in ()
- | Ast0.WhenAlways(x) -> let _ = allfn x in ()
- | Ast0.WhenModifier(_) -> ()
- | Ast0.WhenNotTrue(x) -> let _ = exp x in ()
- | Ast0.WhenNotFalse(x) -> let _ = exp x in () in
-
- (* assume that all of the declarations are at the beginning of a statement
- list, which is required by C, but not actually required by the cocci
- parser *)
- let rec process_statement_list r acc = function
- [] -> acc
- | (s::ss) ->
- (match Ast0.unwrap s with
- Ast0.Decl(_,decl) ->
- let rec process_decl decl =
- match Ast0.unwrap decl with
- Ast0.Init(_,ty,id,_,exp,_) ->
- let _ =
- (propagate_types acc).V0.combiner_initialiser exp in
- [(strip id,Ast0.ast0_type_to_type ty)]
- | Ast0.UnInit(_,ty,id,_) ->
- [(strip id,Ast0.ast0_type_to_type ty)]
- | Ast0.MacroDecl(_,_,_,_,_) -> []
- | Ast0.TyDecl(ty,_) -> []
- (* pad: should handle typedef one day and add a binding *)
- | Ast0.Typedef(_,_,_,_) -> []
- | Ast0.DisjDecl(_,disjs,_,_) ->
- List.concat(List.map process_decl disjs)
- | Ast0.Ddots(_,_) -> [] (* not in a statement list anyway *)
- | Ast0.OptDecl(decl) -> process_decl decl
- | Ast0.UniqueDecl(decl) -> process_decl decl in
- let new_acc = (process_decl decl)@acc in
- process_statement_list r new_acc ss
- | Ast0.Dots(_,wc) ->
- (* why is this case here? why is there none for nests? *)
- List.iter
- (process_whencode r.V0.combiner_statement_dots
- r.V0.combiner_statement r.V0.combiner_expression)
- wc;
- process_statement_list r acc ss
- | Ast0.Disj(_,statement_dots_list,_,_) ->
- let new_acc =
- lub_envs
- (List.map
- (function x -> process_statement_list r acc (Ast0.undots x))
- statement_dots_list) in
- process_statement_list r new_acc ss
- | _ ->
- let _ = (propagate_types acc).V0.combiner_statement s in
- process_statement_list r acc ss) in
-
- let statement_dots r k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- let _ = process_statement_list r env l in option_default in
- let statement r k s =
- match Ast0.unwrap s with
- Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- let rec get_binding p =
- match Ast0.unwrap p with
- Ast0.Param(ty,Some id) ->
- [(strip id,Ast0.ast0_type_to_type ty)]
- | Ast0.OptParam(param) -> get_binding param
- | _ -> [] in
- let fenv = List.concat (List.map get_binding (Ast0.undots params)) in
- (propagate_types (fenv@env)).V0.combiner_statement_dots body
- | Ast0.IfThen(_,_,exp,_,_,_) | Ast0.IfThenElse(_,_,exp,_,_,_,_,_)
- | Ast0.While(_,_,exp,_,_,_) | Ast0.Do(_,_,_,_,exp,_,_)
- | Ast0.For(_,_,_,_,Some exp,_,_,_,_,_) | Ast0.Switch(_,_,exp,_,_,_,_) ->
- let _ = k s in
- let rec process_test exp =
- match (Ast0.unwrap exp,Ast0.get_type exp) with
- (Ast0.Edots(_,_),_) -> None
- | (Ast0.NestExpr(_,_,_,_,_),_) -> None
- | (Ast0.MetaExpr(_,_,_,_,_),_) ->
- (* if a type is known, it is specified in the decl *)
- None
- | (Ast0.Paren(lp,exp,rp),None) -> process_test exp
- | (_,None) -> Some (int_type)
- | _ -> None in
- let new_expty = process_test exp in
- (match new_expty with
- None -> () (* leave things as they are *)
- | Some ty -> Ast0.set_type exp new_expty);
- None
- | _ -> k s
-
- and case_line r k c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) -> let _ = k c in None
- | Ast0.Case(case,exp,colon,code) ->
- let _ = k c in
- (match Ast0.get_type exp with
- None -> Ast0.set_type exp (Some (int_type))
- | _ -> ());
- None
- | Ast0.OptCase(case) -> k c in
-
- V0.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing statement_dots donothing donothing
- ident expression donothing donothing donothing donothing statement
- case_line donothing
-
-let type_infer code =
- let prop = propagate_types [(Id("NULL"),T.Pointer(T.Unknown))] in
- let fn = prop.V0.combiner_top_level in
- let _ = List.map fn code in
- ()
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-(* --------------------------------------------------------------------- *)
-(* Given two patterns, A and B, determine whether B can match any matched
-subterms of A. For simplicity, this doesn't maintain an environment; it
-just assume metavariables match. Thus the result is either NO or MAYBE. *)
-
-module Ast = Ast_cocci
-module V = Visitor_ast
-
-(* --------------------------------------------------------------------- *)
-
-type res = NO | MAYBE
-
-let return b = if b then MAYBE else NO
-
-let unify_mcode (x,_,_,_) (y,_,_,_) = x = y
-
-let ret_unify_mcode a b = return (unify_mcode a b)
-
-let unify_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> return true
- | _ -> return false
-
-let unify_true_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> return true
- | _ -> return true
-
-let bool_unify_option f t1 t2 =
- match (t1,t2) with
- (Some t1, Some t2) -> f t1 t2
- | (None, None) -> true
- | _ -> false
-
-let conjunct_bindings b1 b2 =
- match b1 with NO -> b1 | MAYBE -> b2
-
-let disjunct_bindings b1 b2 =
- match b1 with MAYBE -> b1 | NO -> b2
-
-let disjunct_all_bindings = List.fold_left disjunct_bindings NO
-
-(* --------------------------------------------------------------------- *)
-
-(* compute the common prefix. if in at least one case, this ends with the
-end of the pattern or a ..., then return true. *)
-
-let unify_lists fn dfn la lb =
- let rec loop = function
- ([],_) | (_,[]) -> return true
- | (cura::resta,curb::restb) ->
- (match fn cura curb with
- MAYBE -> loop (resta,restb)
- | NO -> if dfn cura or dfn curb then MAYBE else NO) in
- loop (la,lb)
-
-let unify_dots fn dfn d1 d2 =
- match (Ast.unwrap d1,Ast.unwrap d2) with
- (Ast.DOTS(l1),Ast.DOTS(l2))
- | (Ast.CIRCLES(l1),Ast.CIRCLES(l2))
- | (Ast.STARS(l1),Ast.STARS(l2)) -> unify_lists fn dfn l1 l2
- | _ -> return false
-
-let edots e =
- match Ast.unwrap e with
- Ast.Edots(_,_) | Ast.Ecircles(_,_) | Ast.Estars(_,_) -> true
- | _ -> false
-
-let ddots e =
- match Ast.unwrap e with
- Ast.Ddots(_,_) -> true
- | _ -> false
-
-let pdots p =
- match Ast.unwrap p with
- Ast.Pdots(_) | Ast.Pcircles(_) -> true
- | _ -> false
-
-let dpdots e =
- match Ast.unwrap e with
- Ast.DPdots(_) | Ast.DPcircles(_) -> true
- | _ -> false
-
-let sdots s =
- match Ast.unwrap s with
- Ast.Dots(_,_,_,_) | Ast.Circles(_,_,_,_) | Ast.Stars(_,_,_,_) -> true
- | _ -> false
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-and unify_ident i1 i2 =
- match (Ast.unwrap i1,Ast.unwrap i2) with
- (Ast.Id(i1),Ast.Id(i2)) -> return (unify_mcode i1 i2)
-
- | (Ast.MetaId(_,_,_,_),_)
- | (Ast.MetaFunc(_,_,_,_),_)
- | (Ast.MetaLocalFunc(_,_,_,_),_)
- | (_,Ast.MetaId(_,_,_,_))
- | (_,Ast.MetaFunc(_,_,_,_))
- | (_,Ast.MetaLocalFunc(_,_,_,_)) -> return true
-
- | (Ast.OptIdent(_),_)
- | (Ast.UniqueIdent(_),_)
- | (_,Ast.OptIdent(_))
- | (_,Ast.UniqueIdent(_)) -> failwith "unsupported ident"
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let rec unify_expression e1 e2 =
- match (Ast.unwrap e1,Ast.unwrap e2) with
- (Ast.Ident(i1),Ast.Ident(i2)) -> unify_ident i1 i2
- | (Ast.Constant(c1),Ast.Constant(c2))-> return (unify_mcode c1 c2)
- | (Ast.FunCall(f1,lp1,args1,rp1),Ast.FunCall(f2,lp2,args2,rp2)) ->
- conjunct_bindings
- (unify_expression f1 f2)
- (unify_dots unify_expression edots args1 args2)
- | (Ast.Assignment(l1,op1,r1,_),Ast.Assignment(l2,op2,r2,_)) ->
- if unify_mcode op1 op2
- then conjunct_bindings (unify_expression l1 l2) (unify_expression r1 r2)
- else return false
- | (Ast.CondExpr(tst1,q1,thn1,c1,els1),Ast.CondExpr(tst2,q2,thn2,c2,els2)) ->
- conjunct_bindings (unify_expression tst1 tst2)
- (conjunct_bindings (unify_option unify_expression thn1 thn2)
- (unify_expression els1 els2))
- | (Ast.Postfix(e1,op1),Ast.Postfix(e2,op2)) ->
- if unify_mcode op1 op2 then unify_expression e1 e2 else return false
- | (Ast.Infix(e1,op1),Ast.Infix(e2,op2)) ->
- if unify_mcode op1 op2 then unify_expression e1 e2 else return false
- | (Ast.Unary(e1,op1),Ast.Unary(e2,op2)) ->
- if unify_mcode op1 op2 then unify_expression e1 e2 else return false
- | (Ast.Binary(l1,op1,r1),Ast.Binary(l2,op2,r2)) ->
- if unify_mcode op1 op2
- then conjunct_bindings (unify_expression l1 l2) (unify_expression r1 r2)
- else return false
- | (Ast.ArrayAccess(ar1,lb1,e1,rb1),Ast.ArrayAccess(ar2,lb2,e2,rb2)) ->
- conjunct_bindings (unify_expression ar1 ar2) (unify_expression e1 e2)
- | (Ast.RecordAccess(e1,d1,fld1),Ast.RecordAccess(e2,d2,fld2)) ->
- conjunct_bindings (unify_expression e1 e2) (unify_ident fld1 fld2)
- | (Ast.RecordPtAccess(e1,pt1,fld1),Ast.RecordPtAccess(e2,pt2,fld2)) ->
- conjunct_bindings (unify_expression e1 e2) (unify_ident fld1 fld2)
- | (Ast.Cast(lp1,ty1,rp1,e1),Ast.Cast(lp2,ty2,rp2,e2)) ->
- conjunct_bindings (unify_fullType ty1 ty2) (unify_expression e1 e2)
- | (Ast.SizeOfExpr(szf1,e1),Ast.SizeOfExpr(szf2,e2)) ->
- unify_expression e1 e2
- | (Ast.SizeOfType(szf1,lp1,ty1,rp1),Ast.SizeOfType(szf2,lp2,ty2,rp2)) ->
- unify_fullType ty1 ty2
- | (Ast.TypeExp(ty1),Ast.TypeExp(ty2)) -> unify_fullType ty1 ty2
- | (Ast.Paren(lp1,e1,rp1),Ast.Paren(lp2,e2,rp2)) ->
- unify_expression e1 e2
-
- | (Ast.MetaErr(_,_,_,_),_)
- | (Ast.MetaExpr(_,_,_,_,_,_),_)
- | (Ast.MetaExprList(_,_,_,_),_)
- | (_,Ast.MetaErr(_,_,_,_))
- | (_,Ast.MetaExpr(_,_,_,_,_,_))
- | (_,Ast.MetaExprList(_,_,_,_)) -> return true
-
- | (Ast.EComma(cm1),Ast.EComma(cm2)) -> return true
-
- | (Ast.DisjExpr(e1),_) ->
- disjunct_all_bindings (List.map (function x -> unify_expression x e2) e1)
- | (_,Ast.DisjExpr(e2)) ->
- disjunct_all_bindings (List.map (function x -> unify_expression e1 x) e2)
- | (Ast.NestExpr(e1,_,_),Ast.NestExpr(e2,_,_)) ->
- unify_dots unify_expression edots e1 e2
-
- (* dots can match against anything. return true to be safe. *)
- | (Ast.Edots(_,_),_) | (_,Ast.Edots(_,_))
- | (Ast.Ecircles(_,_),_) | (_,Ast.Ecircles(_,_))
- | (Ast.Estars(_,_),_) | (_,Ast.Estars(_,_)) -> return true
-
- | (Ast.OptExp(_),_)
- | (Ast.UniqueExp(_),_)
- | (_,Ast.OptExp(_))
- | (_,Ast.UniqueExp(_)) -> failwith "unsupported expression"
- | _ -> return false
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and unify_fullType ft1 ft2 =
- match (Ast.unwrap ft1,Ast.unwrap ft2) with
- (Ast.Type(cv1,ty1),Ast.Type(cv2,ty2)) ->
- if bool_unify_option unify_mcode cv1 cv2
- then unify_typeC ty1 ty2
- else return false
- | (Ast.DisjType(ft1),_) ->
- disjunct_all_bindings (List.map (function x -> unify_fullType x ft2) ft1)
- | (_,Ast.DisjType(ft2)) ->
- disjunct_all_bindings (List.map (function x -> unify_fullType ft1 x) ft2)
-
- | (Ast.OptType(_),_)
- | (Ast.UniqueType(_),_)
- | (_,Ast.OptType(_))
- | (_,Ast.UniqueType(_)) -> failwith "unsupported type"
-
-and unify_typeC t1 t2 =
- match (Ast.unwrap t1,Ast.unwrap t2) with
- (Ast.BaseType(ty1,stringsa),Ast.BaseType(ty2,stringsb)) ->
- if ty1 = ty2
- then
- unify_lists ret_unify_mcode (function _ -> false (* not dots*))
- stringsa stringsb
- else return false
- | (Ast.SignedT(sgn1,ty1),Ast.SignedT(sgn2,ty2)) ->
- if unify_mcode sgn1 sgn2
- then unify_option unify_typeC ty1 ty2
- else return false
- | (Ast.Pointer(ty1,s1),Ast.Pointer(ty2,s2)) -> unify_fullType ty1 ty2
- | (Ast.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
- Ast.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) ->
- if List.for_all2 unify_mcode
- [lp1a;stara;rp1a;lp2a;rp2a] [lp1b;starb;rp1b;lp2b;rp2b]
- then
- conjunct_bindings (unify_fullType tya tyb)
- (unify_dots unify_parameterTypeDef pdots paramsa paramsb)
- else return false
- | (Ast.FunctionType(_,tya,lp1a,paramsa,rp1a),
- Ast.FunctionType(_,tyb,lp1b,paramsb,rp1b)) ->
- if List.for_all2 unify_mcode [lp1a;rp1a] [lp1b;rp1b]
- then
- conjunct_bindings (unify_option unify_fullType tya tyb)
- (unify_dots unify_parameterTypeDef pdots paramsa paramsb)
- else return false
- | (Ast.FunctionType _ , _) -> failwith "not supported"
- | (Ast.Array(ty1,lb1,e1,rb1),Ast.Array(ty2,lb2,e2,rb2)) ->
- conjunct_bindings
- (unify_fullType ty1 ty2) (unify_option unify_expression e1 e2)
- | (Ast.EnumName(s1,ts1),Ast.EnumName(s2,ts2)) ->
- if unify_mcode s1 s2 then unify_ident ts1 ts2 else return false
- | (Ast.StructUnionName(s1,Some ts1),Ast.StructUnionName(s2,Some ts2)) ->
- if unify_mcode s1 s2 then unify_ident ts1 ts2 else return false
- | (Ast.StructUnionName(s1,None),Ast.StructUnionName(s2,None)) ->
- return true
- | (Ast.StructUnionDef(ty1,lb1,decls1,rb1),
- Ast.StructUnionDef(ty2,lb2,decls2,rb2)) ->
- conjunct_bindings (unify_fullType ty1 ty2)
- (unify_dots unify_declaration ddots decls1 decls2)
- | (Ast.TypeName(t1),Ast.TypeName(t2)) -> return (unify_mcode t1 t2)
-
- | (Ast.MetaType(_,_,_),_)
- | (_,Ast.MetaType(_,_,_)) -> return true
- | _ -> return false
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and unify_declaration d1 d2 =
- match (Ast.unwrap d1,Ast.unwrap d2) with
- (Ast.Init(stg1,ft1,id1,eq1,i1,s1),Ast.Init(stg2,ft2,id2,eq2,i2,s2)) ->
- if bool_unify_option unify_mcode stg1 stg2
- then
- conjunct_bindings (unify_fullType ft1 ft2)
- (conjunct_bindings (unify_ident id1 id2) (unify_initialiser i1 i2))
- else return false
- | (Ast.UnInit(stg1,ft1,id1,s1),Ast.UnInit(stg2,ft2,id2,s2)) ->
- if bool_unify_option unify_mcode stg1 stg2
- then conjunct_bindings (unify_fullType ft1 ft2) (unify_ident id1 id2)
- else return false
- | (Ast.MacroDecl(n1,lp1,args1,rp1,sem1),
- Ast.MacroDecl(n2,lp2,args2,rp2,sem2)) ->
- conjunct_bindings (unify_ident n1 n2)
- (unify_dots unify_expression edots args1 args2)
- | (Ast.TyDecl(ft1,s1),Ast.TyDecl(ft2,s2)) -> unify_fullType ft1 ft2
- | (Ast.Typedef(stg1,ft1,id1,s1),Ast.Typedef(stg2,ft2,id2,s2)) ->
- conjunct_bindings (unify_fullType ft1 ft2) (unify_typeC id1 id2)
- | (Ast.DisjDecl(d1),_) ->
- disjunct_all_bindings
- (List.map (function x -> unify_declaration x d2) d1)
- | (_,Ast.DisjDecl(d2)) ->
- disjunct_all_bindings
- (List.map (function x -> unify_declaration d1 x) d2)
- (* dots can match against anything. return true to be safe. *)
- | (Ast.Ddots(_,_),_) | (_,Ast.Ddots(_,_)) -> return true
-
- | (Ast.OptDecl(_),_)
- | (Ast.UniqueDecl(_),_)
- | (_,Ast.OptDecl(_))
- | (_,Ast.UniqueDecl(_)) -> failwith "unsupported decl"
- | _ -> return false
-
-(* --------------------------------------------------------------------- *)
-(* Initializer *)
-
-and unify_initialiser i1 i2 =
- match (Ast.unwrap i1,Ast.unwrap i2) with
- (Ast.InitExpr(expa),Ast.InitExpr(expb)) ->
- unify_expression expa expb
- | (Ast.InitList(_,initlista,_,whena),
- Ast.InitList(_,initlistb,_,whenb)) ->
- (* ignore whencode - returns true safely *)
- unify_lists unify_initialiser (function _ -> false) initlista initlistb
- | (Ast.InitGccDotName(_,namea,_,inia),
- Ast.InitGccDotName(_,nameb,_,inib)) ->
- conjunct_bindings
- (unify_ident namea nameb) (unify_initialiser inia inib)
- | (Ast.InitGccName(namea,_,inia),Ast.InitGccName(nameb,_,inib)) ->
- conjunct_bindings (unify_ident namea nameb) (unify_initialiser inia inib)
- | (Ast.InitGccIndex(_,expa,_,_,inia),
- Ast.InitGccIndex(_,expb,_,_,inib)) ->
- conjunct_bindings
- (unify_expression expa expb) (unify_initialiser inia inib)
- | (Ast.InitGccRange(_,exp1a,_,exp2a,_,_,inia),
- Ast.InitGccRange(_,exp1b,_,exp2b,_,_,inib)) ->
- conjunct_bindings (unify_expression exp1a exp1b)
- (conjunct_bindings (unify_expression exp2a exp2b)
- (unify_initialiser inia inib))
-
- | (Ast.OptIni(_),_)
- | (Ast.UniqueIni(_),_)
- | (_,Ast.OptIni(_))
- | (_,Ast.UniqueIni(_)) -> failwith "unsupported decl"
- | _ -> return false
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and unify_parameterTypeDef p1 p2 =
- match (Ast.unwrap p1,Ast.unwrap p2) with
- (Ast.VoidParam(ft1),Ast.VoidParam(ft2)) -> unify_fullType ft1 ft2
- | (Ast.Param(ft1,i1),Ast.Param(ft2,i2)) ->
- conjunct_bindings (unify_fullType ft1 ft2)
- (unify_option unify_ident i1 i2)
-
- | (Ast.MetaParam(_,_,_),_)
- | (Ast.MetaParamList(_,_,_,_),_)
- | (_,Ast.MetaParam(_,_,_))
- | (_,Ast.MetaParamList(_,_,_,_)) -> return true
-
- | (Ast.PComma(_),Ast.PComma(_)) -> return true
-
- (* dots can match against anything. return true to be safe. *)
- | (Ast.Pdots(_),_) | (_,Ast.Pdots(_))
- | (Ast.Pcircles(_),_) | (_,Ast.Pcircles(_)) -> return true
-
- | (Ast.OptParam(_),_)
- | (Ast.UniqueParam(_),_)
- | (_,Ast.OptParam(_))
- | (_,Ast.UniqueParam(_)) -> failwith "unsupported parameter"
- | _ -> return false
-
-(* --------------------------------------------------------------------- *)
-(* Define parameter *)
-
-and unify_define_parameters p1 p2 =
- match (Ast.unwrap p1,Ast.unwrap p2) with
- (Ast.NoParams,Ast.NoParams) -> return true
- | (Ast.DParams(lp1,params1,rp1),Ast.DParams(lp2,params2,rp2)) ->
- unify_dots unify_define_param dpdots params1 params2
- | _ -> return false
-
-and unify_define_param p1 p2 =
- match (Ast.unwrap p1,Ast.unwrap p2) with
- (Ast.DParam(i1),Ast.DParam(i2)) ->
- (unify_ident i1 i2)
- | (Ast.DPComma(_),Ast.DPComma(_)) -> return true
-
- (* dots can match against anything. return true to be safe. *)
- | (Ast.DPdots(_),_) | (_,Ast.DPdots(_))
- | (Ast.DPcircles(_),_) | (_,Ast.DPcircles(_)) -> return true
-
- | (Ast.OptDParam(_),_)
- | (Ast.UniqueDParam(_),_)
- | (_,Ast.OptDParam(_))
- | (_,Ast.UniqueDParam(_)) -> failwith "unsupported parameter"
- | _ -> return false
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and unify_rule_elem re1 re2 =
- match (Ast.unwrap re1,Ast.unwrap re2) with
- (Ast.FunHeader(_,_,fi1,nm1,lp1,params1,rp1),
- Ast.FunHeader(_,_,fi2,nm2,lp2,params2,rp2)) ->
- conjunct_bindings (unify_fninfo fi1 fi2)
- (conjunct_bindings (unify_ident nm1 nm2)
- (unify_dots unify_parameterTypeDef pdots params1 params2))
- | (Ast.Decl(_,_,d1),Ast.Decl(_,_,d2)) -> unify_declaration d1 d2
-
- | (Ast.SeqStart(lb1),Ast.SeqStart(lb2)) -> return true
- | (Ast.SeqEnd(rb1),Ast.SeqEnd(rb2)) -> return true
-
- | (Ast.ExprStatement(e1,s1),Ast.ExprStatement(e2,s2)) ->
- unify_expression e1 e2
- | (Ast.IfHeader(if1,lp1,e1,rp1),Ast.IfHeader(if2,lp2,e2,rp2)) ->
- unify_expression e1 e2
- | (Ast.Else(e1),Ast.Else(e2)) -> return true
- | (Ast.WhileHeader(wh1,lp1,e1,rp1),Ast.WhileHeader(wh2,lp2,e2,rp2)) ->
- unify_expression e1 e2
- | (Ast.DoHeader(d1),Ast.DoHeader(d2)) -> return true
- | (Ast.WhileTail(wh1,lp1,e1,rp1,s1),Ast.WhileTail(wh2,lp2,e2,rp2,s2)) ->
- unify_expression e1 e2
- | (Ast.ForHeader(fr1,lp1,e11,s11,e21,s21,e31,rp1),
- Ast.ForHeader(fr2,lp2,e12,s12,e22,s22,e32,rp2)) ->
- conjunct_bindings
- (unify_option unify_expression e11 e12)
- (conjunct_bindings
- (unify_option unify_expression e21 e22)
- (unify_option unify_expression e31 e32))
- | (Ast.IteratorHeader(nm1,lp1,args1,rp1),
- Ast.IteratorHeader(nm2,lp2,args2,rp2)) ->
- conjunct_bindings (unify_ident nm1 nm2)
- (unify_dots unify_expression edots args1 args2)
- | (Ast.DefineHeader(_,n1,p1),Ast.DefineHeader(_,n2,p2)) ->
- conjunct_bindings (unify_ident n1 n2)
- (unify_define_parameters p1 p2)
- | (Ast.Break(r1,s1),Ast.Break(r2,s2)) -> return true
- | (Ast.Continue(r1,s1),Ast.Continue(r2,s2)) -> return true
- | (Ast.Label(l1,dd1),Ast.Label(l2,dd2)) -> unify_ident l1 l2
- | (Ast.Goto(g1,l1,dd1),Ast.Goto(g2,l2,dd2)) -> unify_ident l1 l2
- | (Ast.Return(r1,s1),Ast.Return(r2,s2)) -> return true
- | (Ast.ReturnExpr(r1,e1,s1),Ast.ReturnExpr(r2,e2,s2)) ->
- unify_expression e1 e2
-
- | (Ast.DisjRuleElem(res1),_) ->
- disjunct_all_bindings
- (List.map (function x -> unify_rule_elem x re2) res1)
- | (_,Ast.DisjRuleElem(res2)) ->
- disjunct_all_bindings
- (List.map (function x -> unify_rule_elem re1 x) res2)
-
- | (Ast.MetaRuleElem(_,_,_),_)
- | (Ast.MetaStmt(_,_,_,_),_)
- | (Ast.MetaStmtList(_,_,_),_)
- | (_,Ast.MetaRuleElem(_,_,_))
- | (_,Ast.MetaStmt(_,_,_,_))
- | (_,Ast.MetaStmtList(_,_,_)) -> return true
-
- (* can match a rule_elem in different parts *)
- | (Ast.Exp(e1),Ast.Exp(e2)) -> return true
- | (Ast.Exp(e1),_) -> subexp (unify_expression e1) re2
- | (_,Ast.Exp(e2)) -> subexp (unify_expression e2) re1
-
- | (Ast.TopExp(e1),Ast.TopExp(e2)) -> unify_expression e1 e2
- | (Ast.TopInit(i1),Ast.TopInit(i2)) -> unify_initialiser i1 i2
-
- (* can match a rule_elem in different parts *)
- | (Ast.Ty(t1),Ast.Ty(t2)) -> return true
- | (Ast.Ty(t1),_) -> subtype (unify_fullType t1) re2
- | (_,Ast.Ty(t2)) -> subtype (unify_fullType t2) re1
- | _ -> return false
-
-and unify_fninfo patterninfo cinfo =
- let patterninfo = List.sort compare patterninfo in
- let cinfo = List.sort compare cinfo in
- let rec loop = function
- (Ast.FStorage(sta)::resta,Ast.FStorage(stb)::restb) ->
- if unify_mcode sta stb then loop (resta,restb) else return false
- | (Ast.FType(tya)::resta,Ast.FType(tyb)::restb) ->
- conjunct_bindings (unify_fullType tya tyb) (loop (resta,restb))
- | (Ast.FInline(ia)::resta,Ast.FInline(ib)::restb) ->
- if unify_mcode ia ib then loop (resta,restb) else return false
- | (Ast.FAttr(ia)::resta,Ast.FAttr(ib)::restb) ->
- if unify_mcode ia ib then loop (resta,restb) else return false
- | (x::resta,((y::_) as restb)) ->
- (match compare x y with
- -1 -> return false
- | 1 -> loop (resta,restb)
- | _ -> failwith "not possible")
- | _ -> return false in
- loop (patterninfo,cinfo)
-
-and subexp f =
- let bind = conjunct_bindings in
- let option_default = return false in
- let mcode r e = option_default in
- let expr r k e = conjunct_bindings (f e) (k e) in
- let donothing r k e = k e in
- let recursor = V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing expr donothing donothing donothing donothing donothing
- donothing donothing donothing donothing donothing in
- recursor.V.combiner_rule_elem
-
-and subtype f =
- let bind = conjunct_bindings in
- let option_default = return false in
- let mcode r e = option_default in
- let fullType r k e = conjunct_bindings (f e) (k e) in
- let donothing r k e = k e in
- let recursor = V.combiner bind option_default
- mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- donothing donothing fullType donothing donothing donothing donothing
- donothing donothing donothing donothing donothing in
- recursor.V.combiner_rule_elem
-
-let rec unify_statement s1 s2 =
- match (Ast.unwrap s1,Ast.unwrap s2) with
- (Ast.Seq(lb1,d1,s1,rb1),Ast.Seq(lb2,d2,s2,rb2)) ->
- conjunct_bindings (unify_rule_elem lb1 lb2)
- (conjunct_bindings
- (unify_dots unify_statement sdots s1 s2)
- (conjunct_bindings
- (unify_dots unify_statement sdots d1 d2)
- (unify_rule_elem rb1 rb2)))
- | (Ast.IfThen(h1,thn1,_),Ast.IfThen(h2,thn2,_)) ->
- conjunct_bindings (unify_rule_elem h1 h2) (unify_statement thn1 thn2)
- | (Ast.IfThenElse(h1,thn1,e1,els1,_),Ast.IfThenElse(h2,thn2,e2,els2,_)) ->
- conjunct_bindings (unify_rule_elem h1 h2)
- (conjunct_bindings (unify_statement thn1 thn2)
- (conjunct_bindings (unify_rule_elem e1 e2)
- (unify_statement els1 els2)))
- | (Ast.While(h1,s1,_),Ast.While(h2,s2,_)) ->
- conjunct_bindings (unify_rule_elem h1 h2) (unify_statement s1 s2)
- | (Ast.Do(h1,s1,t1),Ast.Do(h2,s2,t2)) ->
- conjunct_bindings (unify_rule_elem h1 h2)
- (conjunct_bindings (unify_statement s1 s2) (unify_rule_elem t1 t2))
- | (Ast.For(h1,s1,_),Ast.For(h2,s2,_)) ->
- conjunct_bindings (unify_rule_elem h1 h2) (unify_statement s1 s2)
- | (Ast.Atomic(re1),Ast.Atomic(re2)) -> unify_rule_elem re1 re2
- | (Ast.Disj(s1),_) ->
- let s2 = Ast.rewrap s2 (Ast.DOTS[s2]) in
- disjunct_all_bindings
- (List.map
- (function x -> unify_dots unify_statement sdots x s2)
- s1)
- | (_,Ast.Disj(s2)) ->
- let s1 = Ast.rewrap s1 (Ast.DOTS[s1]) in
- disjunct_all_bindings
- (List.map
- (function x -> unify_dots unify_statement sdots s1 x)
- s2)
- | (Ast.Nest(s1,_,_,_,_),Ast.Nest(s2,_,_,_,_)) ->
- unify_dots unify_statement sdots s1 s2
- | (Ast.FunDecl(h1,lb1,d1,s1,rb1),Ast.FunDecl(h2,lb2,d2,s2,rb2)) ->
- conjunct_bindings (unify_rule_elem h1 h2)
- (conjunct_bindings (unify_rule_elem lb1 lb2)
- (conjunct_bindings (unify_dots unify_statement sdots d1 d2)
- (conjunct_bindings (unify_dots unify_statement sdots s1 s2)
- (unify_rule_elem rb1 rb2))))
- | (Ast.Define(h1,s1),Ast.Define(h2,s2)) ->
- conjunct_bindings (unify_rule_elem h1 h2)
- (unify_dots unify_statement sdots s1 s2)
- (* dots can match against anything. return true to be safe. *)
- | (Ast.Dots(_,_,_,_),_) | (_,Ast.Dots(_,_,_,_))
- | (Ast.Circles(_,_,_,_),_) | (_,Ast.Circles(_,_,_,_))
- | (Ast.Stars(_,_,_,_),_) | (_,Ast.Stars(_,_,_,_)) -> return true
- | (Ast.OptStm(_),_)
- | (Ast.UniqueStm(_),_)
- | (_,Ast.OptStm(_))
- | (_,Ast.UniqueStm(_)) -> failwith "unsupported statement"
- | _ -> return false
-
-let unify_statement_dots = unify_dots unify_statement sdots
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Format
-module Ast0 = Ast0_cocci
-module U = Pretty_print_cocci
-
-let quiet = ref true (* true = no decoration on - context, etc *)
-
-let start_block str =
- force_newline(); print_string " "; open_box 0
-
-let end_block str =
- close_box(); force_newline ()
-
-let print_option = Common.do_option
-let print_between = Common.print_between
-
-(* --------------------------------------------------------------------- *)
-(* Positions *)
-
-let meta_pos = function
- Ast0.MetaPos(name,_,_) ->
- print_string "@";
- let (_,name) = Ast0.unwrap_mcode name in
- print_string name
- | Ast0.NoMetaPos -> ()
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-let mcodekind brackets fn x info = function
- Ast0.MINUS(plus_stream) ->
- let (lb,rb) =
- if !quiet
- then ("","")
- else
- match brackets with
- Some x -> ("[","]^"^(string_of_int x))
- | None -> ("","") in
- let (plus_stream,_) = !plus_stream in
- if !quiet
- then fn x
- else (print_string "-";
- print_string lb; fn x; print_string rb);
- U.print_anything ">>> " plus_stream
- | Ast0.CONTEXT(plus_streams) ->
- let (lb,rb) =
- if !quiet
- then ("","")
- else
- match brackets with
- Some x -> ("[",("]^"^(string_of_int x))) | None -> ("","") in
- let (plus_streams,t1,t2) = !plus_streams in
- U.print_around
- (function x ->
- print_string lb; fn x; print_string rb)
- x plus_streams
- | Ast0.PLUS ->
- List.iter (function s -> print_string s; force_newline())
- info.Ast0.strings_before;
- fn x;
- List.iter (function s -> force_newline(); print_string s)
- info.Ast0.strings_after
- | Ast0.MIXED(plus_streams) ->
- let (lb,rb) =
- if !quiet
- then ("","")
- else
- let n =
- match brackets with Some x -> "^"^(string_of_int x) | None -> "" in
- ("§","½"^n) in
- let (plus_streams,_,_) = !plus_streams in
- U.print_around (function x -> print_string lb; fn x; print_string rb)
- x plus_streams
-
-let mcode fn (x,_,info,mc,pos) =
- let fn x = fn x; meta_pos !pos in
- mcodekind (Some info.Ast0.line_start)(*None*) fn x info mc
-
-let print_context x fn =
- mcodekind (Some (Ast0.get_line x)) fn () (Ast0.get_info x)
- (Ast0.get_mcodekind x)
-
-let print_meta (_,name) = print_string name
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots between fn d =
- print_context d
- (function _ ->
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> print_between between fn l
- | Ast0.CIRCLES(l) -> print_between between fn l
- | Ast0.STARS(l) -> print_between between fn l)
-
-(* --------------------------------------------------------------------- *)
-
-let print_types = function
- None -> ()
- | Some ty ->
- print_string "/* ";
- Format.print_flush();
- print_between (function _ -> print_string ", ") Type_cocci.typeC ty;
- Format.print_flush();
- print_string " */"
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec ident i =
- print_context i
- (function _ ->
- match Ast0.unwrap i with
- Ast0.Id(name) -> mcode print_string name
- | Ast0.MetaId(name,_,_) -> mcode print_meta name
- | Ast0.MetaFunc(name,_,_) -> mcode print_meta name
- | Ast0.MetaLocalFunc(name,_,_) -> mcode print_meta name
- | Ast0.OptIdent(id) -> print_string "?"; ident id
- | Ast0.UniqueIdent(id) -> print_string "!"; ident id)
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let print_string_box s = print_string s; open_box 0
-
-let rec expression e =
- print_option Type_cocci.typeC (Ast0.get_type e);
- print_context e
- (function _ ->
- match Ast0.unwrap e with
- Ast0.Ident(id) -> ident id
- | Ast0.Constant(const) -> mcode U.constant const
- | Ast0.FunCall(fn,lp,args,rp) ->
- expression fn; mcode print_string_box lp;
- let _ = dots (function _ -> ()) expression args in
- close_box(); mcode print_string rp
- | Ast0.Assignment(left,op,right,_) ->
- expression left; print_string " "; mcode U.assignOp op;
- print_string " "; expression right
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- expression exp1; print_string " "; mcode print_string why;
- print_option (function e -> print_string " "; expression e) exp2;
- print_string " "; mcode print_string colon; expression exp3
- | Ast0.Postfix(exp,op) -> expression exp; mcode U.fixOp op
- | Ast0.Infix(exp,op) -> mcode U.fixOp op; expression exp
- | Ast0.Unary(exp,op) -> mcode U.unaryOp op; expression exp
- | Ast0.Binary(left,op,right) ->
- print_string "(";
- expression left; print_string " "; mcode U.binaryOp op;
- print_string " "; expression right;
- print_string ")"
- | Ast0.Nested(left,op,right) ->
- print_string "(";
- expression left; print_string " "; mcode U.binaryOp op;
- print_string " "; expression right;
- print_string ")"
- | Ast0.Paren(lp,exp,rp) ->
- mcode print_string_box lp; expression exp; close_box();
- mcode print_string rp
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- expression exp1; mcode print_string_box lb; expression exp2;
- close_box(); mcode print_string rb
- | Ast0.RecordAccess(exp,pt,field) ->
- expression exp; mcode print_string pt; ident field
- | Ast0.RecordPtAccess(exp,ar,field) ->
- expression exp; mcode print_string ar; ident field
- | Ast0.Cast(lp,ty,rp,exp) ->
- mcode print_string_box lp; typeC ty; close_box();
- mcode print_string rp; expression exp
- | Ast0.SizeOfExpr(szf,exp) ->
- mcode print_string szf; expression exp
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- mcode print_string szf;
- mcode print_string_box lp; typeC ty; close_box();
- mcode print_string rp
- | Ast0.TypeExp(ty) -> typeC ty
- | Ast0.MetaErr(name,_,_) -> mcode print_meta name
- | Ast0.MetaExpr(name,_,ty,_,pure) ->
- mcode print_meta name; print_types ty(*;
- print_string "^";
- (match pure with
- Ast0.Pure -> print_string "pure"
- | Ast0.Impure -> print_string "impure"
- | Ast0.Context -> print_string "context"
- | Ast0.PureContext -> print_string "pure_context")*)
- | Ast0.MetaExprList(name,_,_) -> mcode print_meta name
- | Ast0.EComma(cm) -> mcode print_string cm; print_space()
- | Ast0.DisjExpr(_,exp_list,_,_) ->
- print_string "\n("; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- expression exp_list;
- print_string "\n)"
- | Ast0.NestExpr(starter,expr_dots,ender,None,multi) ->
- mcode print_string starter;
- start_block(); dots force_newline expression expr_dots; end_block();
- mcode print_string ender
- | Ast0.NestExpr(starter,expr_dots,ender,Some whencode,multi) ->
- mcode print_string starter; print_string " WHEN != ";
- expression whencode;
- start_block(); dots force_newline expression expr_dots; end_block();
- mcode print_string ender
- | Ast0.Edots(dots,Some whencode)
- | Ast0.Ecircles(dots,Some whencode)
- | Ast0.Estars(dots,Some whencode) ->
- mcode print_string dots; print_string " WHEN != ";
- expression whencode
- | Ast0.Edots(dots,None)
- | Ast0.Ecircles(dots,None)
- | Ast0.Estars(dots,None) -> mcode print_string dots
- | Ast0.OptExp(exp) -> print_string "?"; expression exp
- | Ast0.UniqueExp(exp) -> print_string "!"; expression exp)
-
-and expression_dots x = dots (function _ -> ()) expression x
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2) fn =
- typeC ty; mcode print_string lp1; mcode print_string star; fn();
- mcode print_string rp1; mcode print_string lp2;
- parameter_list params; mcode print_string rp2
-
-and print_function_type (ty,lp1,params,rp1) fn =
- print_option typeC ty; fn(); mcode print_string lp1;
- parameter_list params; mcode print_string rp1
-
-and typeC t =
- print_context t
- (function _ ->
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) ->
- mcode U.const_vol cv; print_string " "; typeC ty
- | Ast0.BaseType(ty,strings) ->
- List.iter (function s -> mcode print_string s; print_string " ")
- strings
- | Ast0.Signed(sgn,ty) -> mcode U.sign sgn; print_option typeC ty
- | Ast0.Pointer(ty,star) -> typeC ty; mcode print_string star
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> ())
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1) (function _ -> ())
- | Ast0.Array(ty,lb,size,rb) ->
- typeC ty; mcode print_string lb; print_option expression size;
- mcode print_string rb
- | Ast0.EnumName(kind,name) -> mcode print_string kind; print_string " ";
- ident name
- | Ast0.StructUnionName(kind,name) ->
- mcode U.structUnion kind;
- print_option (function x -> ident x; print_string " ") name
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- typeC ty; mcode print_string lb;
- dots force_newline declaration decls;
- mcode print_string rb
- | Ast0.TypeName(name)-> mcode print_string name; print_string " "
- | Ast0.MetaType(name,_)-> mcode print_meta name; print_string " "
- | Ast0.DisjType(lp,types,mids,rp) ->
- print_string "\n"; mcode print_string lp; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- typeC types;
- print_string "\n"; mcode print_string rp
- | Ast0.OptType(ty) -> print_string "?"; typeC ty
- | Ast0.UniqueType(ty) -> print_string "!"; typeC ty)
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and print_named_type ty id =
- match Ast0.unwrap ty with
- Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> print_string " "; ident id)
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1)
- (function _ -> print_string " "; ident id)
- | Ast0.Array(ty,lb,size,rb) ->
- let rec loop ty k =
- match Ast0.unwrap ty with
- Ast0.Array(ty,lb,size,rb) ->
- loop ty
- (function _ ->
- k ();
- mcode print_string lb;
- print_option expression size;
- mcode print_string rb)
- | _ -> typeC ty; ident id; k () in
- loop ty (function _ -> ())
- | _ -> typeC ty; ident id
-
-and declaration d =
- print_context d
- (function _ ->
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- print_option (mcode U.storage) stg;
- print_named_type ty id;
- print_string " ";
- mcode print_string eq; print_string " "; initialiser ini;
- mcode print_string sem
- | Ast0.UnInit(stg,ty,id,sem) ->
- print_option (mcode U.storage) stg; print_named_type ty id;
- mcode print_string sem
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- ident name; mcode print_string_box lp;
- let _ = dots (function _ -> ()) expression args in
- close_box(); mcode print_string rp; mcode print_string sem
- | Ast0.TyDecl(ty,sem) -> typeC ty; mcode print_string sem
- | Ast0.Typedef(stg,ty,id,sem) ->
- mcode print_string stg; typeC ty; typeC id;
- mcode print_string sem
- | Ast0.DisjDecl(_,decls,_,_) ->
- print_string "\n("; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- declaration decls;
- print_string "\n)"
- | Ast0.Ddots(dots,Some whencode) ->
- mcode print_string dots; print_string " when != ";
- declaration whencode
- | Ast0.Ddots(dots,None) -> mcode print_string dots
- | Ast0.OptDecl(decl) -> print_string "?"; declaration decl
- | Ast0.UniqueDecl(decl) -> print_string "!"; declaration decl)
-
-and declaration_dots l = dots (function _ -> ()) declaration l
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and initialiser i =
- print_context i
- (function _ ->
- match Ast0.unwrap i with
- Ast0.InitExpr(exp) -> expression exp
- | Ast0.InitList(lb,initlist,rb) ->
- mcode print_string lb; open_box 0;
- let _ = dots (function _ -> ()) initialiser initlist in
- close_box(); mcode print_string rb
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- mcode print_string dot; ident name; print_string " ";
- mcode print_string eq; print_string " "; initialiser ini
- | Ast0.InitGccName(name,eq,ini) ->
- ident name; mcode print_string eq; initialiser ini
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- mcode print_string lb; expression exp; mcode print_string rb;
- print_string " "; mcode print_string eq; print_string " ";
- initialiser ini
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- mcode print_string lb; expression exp1; mcode print_string dots;
- expression exp2; mcode print_string rb;
- print_string " "; mcode print_string eq; print_string " ";
- initialiser ini
- | Ast0.IComma(cm) -> mcode print_string cm; force_newline()
- | Ast0.Idots(d,Some whencode) ->
- mcode print_string d; print_string " WHEN != ";
- initialiser whencode
- | Ast0.Idots(d,None) -> mcode print_string d
- | Ast0.OptIni(ini) -> print_string "?"; initialiser ini
- | Ast0.UniqueIni(ini) -> print_string "!"; initialiser ini)
-
-and initialiser_list l = dots (function _ -> ()) initialiser l
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef p =
- print_context p
- (function _ ->
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> typeC ty
- | Ast0.Param(ty,Some id) -> print_named_type ty id
- | Ast0.Param(ty,None) -> typeC ty
- | Ast0.MetaParam(name,_) -> mcode print_meta name
- | Ast0.MetaParamList(name,_,_) -> mcode print_meta name
- | Ast0.PComma(cm) -> mcode print_string cm; print_space()
- | Ast0.Pdots(dots) -> mcode print_string dots
- | Ast0.Pcircles(dots) -> mcode print_string dots
- | Ast0.OptParam(param) -> print_string "?"; parameterTypeDef param
- | Ast0.UniqueParam(param) -> print_string "!"; parameterTypeDef param)
-
-and parameter_list l = dots (function _ -> ()) parameterTypeDef l
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and statement arity s =
- print_context s
- (function _ ->
- match Ast0.unwrap s with
- Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- print_string arity;
- List.iter print_fninfo fninfo;
- ident name; mcode print_string_box lp;
- parameter_list params; close_box(); mcode print_string rp;
- print_string " ";
- print_string arity; mcode print_string lbrace; start_block();
- dots force_newline (statement arity) body;
- end_block(); print_string arity; mcode print_string rbrace
- | Ast0.Decl(_,decl) -> print_string arity; declaration decl
- | Ast0.Seq(lbrace,body,rbrace) ->
- print_string arity; mcode print_string lbrace; start_block();
- dots force_newline (statement arity) body;
- end_block(); print_string arity; mcode print_string rbrace
- | Ast0.ExprStatement(exp,sem) ->
- print_string arity; expression exp; mcode print_string sem
- | Ast0.IfThen(iff,lp,exp,rp,branch1,(info,aft)) ->
- print_string arity;
- mcode print_string iff; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " ";
- statement arity branch1;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,(info,aft)) ->
- print_string arity;
- mcode print_string iff; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " ";
- statement arity branch1;
- print_string arity; mcode print_string els; print_string " ";
- statement arity branch2;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.While(whl,lp,exp,rp,body,(info,aft)) ->
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " ";
- statement arity body;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.Do(d,body,whl,lp,exp,rp,sem) ->
- print_string arity; mcode print_string d; print_string " ";
- statement arity body;
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp;
- mcode print_string sem
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,(info,aft)) ->
- print_string arity;
- mcode print_string fr; mcode print_string_box lp;
- print_option expression e1; mcode print_string sem1;
- print_option expression e2; mcode print_string sem2;
- print_option expression e3; close_box();
- mcode print_string rp; print_string " "; statement arity body;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.Iterator(nm,lp,args,rp,body,(info,aft)) ->
- print_string arity;
- ident nm; print_string " "; mcode print_string_box lp;
- let _ = dots (function _ -> ()) expression args in
- close_box(); mcode print_string rp; print_string " ";
- statement arity body;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- print_string arity;
- mcode print_string switch; print_string " ";
- mcode print_string_box lp; expression exp; close_box();
- mcode print_string rp; print_string " "; mcode print_string lb;
- dots force_newline (case_line arity) cases;
- mcode print_string rb
- | Ast0.Break(br,sem) ->
- print_string arity; mcode print_string br; mcode print_string sem
- | Ast0.Continue(cont,sem) ->
- print_string arity; mcode print_string cont; mcode print_string sem
- | Ast0.Label(l,dd) -> ident l; print_string ":"
- | Ast0.Goto(goto,l,sem) ->
- mcode print_string goto; ident l; mcode print_string sem
- | Ast0.Return(ret,sem) ->
- print_string arity; mcode print_string ret; mcode print_string sem
- | Ast0.ReturnExpr(ret,exp,sem) ->
- print_string arity; mcode print_string ret; print_string " ";
- expression exp; mcode print_string sem
- | Ast0.MetaStmt(name,pure) ->
- print_string arity; mcode print_meta name;(*
- print_string "^";
- (match pure with
- Ast0.Pure -> print_string "pure"
- | Ast0.Impure -> print_string "impure"
- | Ast0.Context -> print_string "context"
- | Ast0.PureContext -> print_string "pure_context")*)
- | Ast0.MetaStmtList(name,_) ->
- print_string arity; mcode print_meta name
- | Ast0.Disj(_,statement_dots_list,_,_) ->
- print_string arity;
- print_string "\n("; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- (dots force_newline (statement arity))
- statement_dots_list;
- print_string "\n)"
- | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
- print_string arity;
- mcode print_string starter;
- open_box 0;
- List.iter
- (whencode (dots force_newline (statement "")) (statement ""))
- whn;
- close_box();
- start_block();
- dots force_newline (statement arity) stmt_dots;
- end_block();
- mcode print_string ender
- | Ast0.Exp(exp) -> print_string arity; expression exp
- | Ast0.TopExp(exp) -> print_string arity; expression exp
- | Ast0.Ty(ty) -> print_string arity; typeC ty
- | Ast0.TopInit(init) -> initialiser init
- | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
- print_string arity; mcode print_string d;
- List.iter
- (whencode (dots force_newline (statement "")) (statement ""))
- whn
- | Ast0.Include(inc,s) ->
- mcode print_string inc; print_string " "; mcode U.inc_file s
- | Ast0.Define(def,id,params,body) ->
- mcode print_string def; print_string " "; ident id;
- print_define_parameters params;
- print_string " ";
- dots force_newline (statement arity) body
- | Ast0.OptStm(re) -> statement "?" re
- | Ast0.UniqueStm(re) -> statement "!" re)
-
-and print_define_parameters params =
- match Ast0.unwrap params with
- Ast0.NoParams -> ()
- | Ast0.DParams(lp,params,rp) ->
- mcode print_string lp;
- dots (function _ -> ()) print_define_param params; mcode print_string rp
-
-and print_define_param param =
- match Ast0.unwrap param with
- Ast0.DParam(id) -> ident id
- | Ast0.DPComma(comma) -> mcode print_string comma
- | Ast0.DPdots(dots) -> mcode print_string dots
- | Ast0.DPcircles(circles) -> mcode print_string circles
- | Ast0.OptDParam(dp) -> print_string "?"; print_define_param dp
- | Ast0.UniqueDParam(dp) -> print_string "!"; print_define_param dp
-
-and print_fninfo = function
- Ast0.FStorage(stg) -> mcode U.storage stg
- | Ast0.FType(ty) -> typeC ty
- | Ast0.FInline(inline) -> mcode print_string inline
- | Ast0.FAttr(attr) -> mcode print_string attr
-
-and whencode notfn alwaysfn = function
- Ast0.WhenNot a ->
- print_string " WHEN != "; open_box 0; notfn a; close_box()
- | Ast0.WhenAlways a ->
- print_string " WHEN = "; open_box 0; alwaysfn a; close_box()
- | Ast0.WhenModifier x -> print_string " WHEN "; U.print_when_modif x
- | Ast0.WhenNotTrue a ->
- print_string " WHEN != TRUE "; open_box 0; expression a; close_box()
- | Ast0.WhenNotFalse a ->
- print_string " WHEN != FALSE "; open_box 0; expression a; close_box()
-
-and case_line arity c =
- print_context c
- (function _ ->
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- print_string arity;
- mcode print_string def; mcode print_string colon; print_string " ";
- dots force_newline (statement arity) code
- | Ast0.Case(case,exp,colon,code) ->
- print_string arity;
- mcode print_string case; print_string " "; expression exp;
- mcode print_string colon; print_string " ";
- dots force_newline (statement arity) code
- | Ast0.OptCase(case) -> case_line "?" case)
-
-and statement_dots l = dots (function _ -> ()) (statement "") l
-and case_dots l = dots (function _ -> ()) (case_line "") l
-
-(* --------------------------------------------------------------------- *)
-(* Top level code *)
-
-let top_level t =
- print_context t
- (function _ ->
- match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- print_string "--- "; mcode print_string old_file; force_newline();
- print_string "+++ "; mcode print_string new_file
- | Ast0.DECL(stmt) -> statement "" stmt
- | Ast0.CODE(stmt_dots) ->
- dots force_newline (statement "") stmt_dots
- | Ast0.ERRORWORDS(exps) ->
- print_string "error words = [";
- print_between (function _ -> print_string ", ") expression exps;
- print_string "]"
- | Ast0.OTHER(s) ->
- print_string "OTHER("; statement "" s; print_string ")")
-
-let rule =
- print_between (function _ -> force_newline(); force_newline()) top_level
-
-let unparse_anything x =
- let q = !quiet in
- quiet := true;
- (match x with
- Ast0.DotsExprTag(d) ->
- print_string "ExpDots:"; force_newline();
- expression_dots d
- | Ast0.DotsParamTag(d) ->
- parameter_list d
- | Ast0.DotsInitTag(d) ->
- initialiser_list d
- | Ast0.DotsStmtTag(d) ->
- print_string "StmDots:"; force_newline();
- statement_dots d
- | Ast0.DotsDeclTag(d) ->
- declaration_dots d
- | Ast0.DotsCaseTag(d) ->
- case_dots d
- | Ast0.IdentTag(d) ->
- ident d
- | Ast0.ExprTag(d) | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- print_string "Exp:"; force_newline();
- expression d
- | Ast0.TypeCTag(d) ->
- typeC d
- | Ast0.ParamTag(d) ->
- parameterTypeDef d
- | Ast0.InitTag(d) ->
- initialiser d
- | Ast0.DeclTag(d) ->
- declaration d
- | Ast0.StmtTag(d) ->
- print_string "Stm:"; force_newline();
- statement "" d
- | Ast0.CaseLineTag(d) ->
- case_line "" d
- | Ast0.TopTag(d) ->
- top_level d
- | Ast0.IsoWhenTag(x) -> U.print_when_modif x
- | Ast0.IsoWhenTTag(e) -> expression e
- | Ast0.IsoWhenFTag(e) -> expression e
- | Ast0.MetaPosTag(var) -> meta_pos var);
- quiet := q;
- print_newline()
-
-let unparse x =
- print_string "\n@@\n@@";
- force_newline();
- force_newline();
- rule x;
- print_newline()
-
-let unparse_to_string x = Common.format_to_string (function _ -> unparse x)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Format
-module Ast0 = Ast0_cocci
-module U = Pretty_print_cocci
-
-let quiet = ref true (* true = no decoration on - context, etc *)
-
-let start_block str =
- force_newline(); print_string " "; open_box 0
-
-let end_block str =
- close_box(); force_newline ()
-
-let print_option = Common.do_option
-let print_between = Common.print_between
-
-(* --------------------------------------------------------------------- *)
-(* Positions *)
-
-let meta_pos = function
- Ast0.MetaPos(name,_,_) ->
- print_string "@";
- let (_,name) = Ast0.unwrap_mcode name in
- print_string name
- | Ast0.NoMetaPos -> ()
-
-(* --------------------------------------------------------------------- *)
-(* Modified code *)
-
-let mcodekind brackets fn x info = function
- Ast0.MINUS(plus_stream) ->
- let (lb,rb) =
- if !quiet
- then ("","")
- else
- match brackets with
- Some x -> ("[","]^"^(string_of_int x))
- | None -> ("","") in
- let (plus_stream,_) = !plus_stream in
- if !quiet
- then fn x
- else (print_string "-";
- print_string lb; fn x; print_string rb);
- U.print_anything ">>> " plus_stream
- | Ast0.CONTEXT(plus_streams) ->
- let (lb,rb) =
- if !quiet
- then ("","")
- else
- match brackets with
- Some x -> ("[",("]^"^(string_of_int x))) | None -> ("","") in
- let (plus_streams,t1,t2) = !plus_streams in
- U.print_around
- (function x ->
- print_string lb; fn x; print_string rb)
- x plus_streams
- | Ast0.PLUS ->
- List.iter (function s -> print_string s; force_newline())
- info.Ast0.strings_before;
- fn x;
- List.iter (function s -> force_newline(); print_string s)
- info.Ast0.strings_after
- | Ast0.MIXED(plus_streams) ->
- let (lb,rb) =
- if !quiet
- then ("","")
- else
- let n =
- match brackets with Some x -> "^"^(string_of_int x) | None -> "" in
- ("§","½"^n) in
- let (plus_streams,_,_) = !plus_streams in
- U.print_around (function x -> print_string lb; fn x; print_string rb)
- x plus_streams
-
-let mcode fn (x,_,info,mc,pos) =
- let fn x = fn x; meta_pos !pos in
- mcodekind (Some info.Ast0.line_start)(*None*) fn x info mc
-
-let print_context x fn =
- mcodekind (Some (Ast0.get_line x)) fn () (Ast0.get_info x)
- (Ast0.get_mcodekind x)
-
-let print_meta (_,name) = print_string name
-
-(* --------------------------------------------------------------------- *)
-(* --------------------------------------------------------------------- *)
-(* Dots *)
-
-let dots between fn d =
- print_context d
- (function _ ->
- match Ast0.unwrap d with
- Ast0.DOTS(l) -> print_between between fn l
- | Ast0.CIRCLES(l) -> print_between between fn l
- | Ast0.STARS(l) -> print_between between fn l)
-
-(* --------------------------------------------------------------------- *)
-
-let print_types = function
- None -> ()
- | Some ty ->
- print_string "/* ";
- Format.print_flush();
- print_between (function _ -> print_string ", ") Type_cocci.typeC ty;
- Format.print_flush();
- print_string " */"
-
-(* --------------------------------------------------------------------- *)
-(* Identifier *)
-
-let rec ident i =
- print_context i
- (function _ ->
- match Ast0.unwrap i with
- Ast0.Id(name) -> mcode print_string name
- | Ast0.MetaId(name,_,_) -> mcode print_meta name
- | Ast0.MetaFunc(name,_,_) -> mcode print_meta name
- | Ast0.MetaLocalFunc(name,_,_) -> mcode print_meta name
- | Ast0.OptIdent(id) -> print_string "?"; ident id
- | Ast0.UniqueIdent(id) -> print_string "!"; ident id)
-
-(* --------------------------------------------------------------------- *)
-(* Expression *)
-
-let print_string_box s = print_string s; open_box 0
-
-let rec expression e =
- print_option Type_cocci.typeC (Ast0.get_type e);
- print_context e
- (function _ ->
- match Ast0.unwrap e with
- Ast0.Ident(id) -> ident id
- | Ast0.Constant(const) -> mcode U.constant const
- | Ast0.FunCall(fn,lp,args,rp) ->
- expression fn; mcode print_string_box lp;
- let _ = dots (function _ -> ()) expression args in
- close_box(); mcode print_string rp
- | Ast0.Assignment(left,op,right,_) ->
- expression left; print_string " "; mcode U.assignOp op;
- print_string " "; expression right
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- expression exp1; print_string " "; mcode print_string why;
- print_option (function e -> print_string " "; expression e) exp2;
- print_string " "; mcode print_string colon; expression exp3
- | Ast0.Postfix(exp,op) -> expression exp; mcode U.fixOp op
- | Ast0.Infix(exp,op) -> mcode U.fixOp op; expression exp
- | Ast0.Unary(exp,op) -> mcode U.unaryOp op; expression exp
- | Ast0.Binary(left,op,right) ->
- print_string "(";
- expression left; print_string " "; mcode U.binaryOp op;
- print_string " "; expression right;
- print_string ")"
- | Ast0.Nested(left,op,right) ->
- print_string "(";
- expression left; print_string " "; mcode U.binaryOp op;
- print_string " "; expression right;
- print_string ")"
- | Ast0.Paren(lp,exp,rp) ->
- mcode print_string_box lp; expression exp; close_box();
- mcode print_string rp
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- expression exp1; mcode print_string_box lb; expression exp2;
- close_box(); mcode print_string rb
- | Ast0.RecordAccess(exp,pt,field) ->
- expression exp; mcode print_string pt; ident field
- | Ast0.RecordPtAccess(exp,ar,field) ->
- expression exp; mcode print_string ar; ident field
- | Ast0.Cast(lp,ty,rp,exp) ->
- mcode print_string_box lp; typeC ty; close_box();
- mcode print_string rp; expression exp
- | Ast0.SizeOfExpr(szf,exp) ->
- mcode print_string szf; expression exp
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- mcode print_string szf;
- mcode print_string_box lp; typeC ty; close_box();
- mcode print_string rp
- | Ast0.TypeExp(ty) -> typeC ty
- | Ast0.MetaErr(name,_,_) -> mcode print_meta name
- | Ast0.MetaExpr(name,_,ty,_,pure) ->
- mcode print_meta name; print_types ty(*;
- print_string "^";
- (match pure with
- Ast0.Pure -> print_string "pure"
- | Ast0.Impure -> print_string "impure"
- | Ast0.Context -> print_string "context"
- | Ast0.PureContext -> print_string "pure_context")*)
- | Ast0.MetaExprList(name,_,_) -> mcode print_meta name
- | Ast0.EComma(cm) -> mcode print_string cm; print_space()
- | Ast0.DisjExpr(_,exp_list,_,_) ->
- print_string "\n("; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- expression exp_list;
- print_string "\n)"
- | Ast0.NestExpr(starter,expr_dots,ender,None,multi) ->
- mcode print_string starter;
- start_block(); dots force_newline expression expr_dots; end_block();
- mcode print_string ender
- | Ast0.NestExpr(starter,expr_dots,ender,Some whencode,multi) ->
- mcode print_string starter; print_string " WHEN != ";
- expression whencode;
- start_block(); dots force_newline expression expr_dots; end_block();
- mcode print_string ender
- | Ast0.Edots(dots,Some whencode)
- | Ast0.Ecircles(dots,Some whencode)
- | Ast0.Estars(dots,Some whencode) ->
- mcode print_string dots; print_string " WHEN != ";
- expression whencode
- | Ast0.Edots(dots,None)
- | Ast0.Ecircles(dots,None)
- | Ast0.Estars(dots,None) -> mcode print_string dots
- | Ast0.OptExp(exp) -> print_string "?"; expression exp
- | Ast0.UniqueExp(exp) -> print_string "!"; expression exp)
-
-and expression_dots x = dots (function _ -> ()) expression x
-
-(* --------------------------------------------------------------------- *)
-(* Types *)
-
-and print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2) fn =
- typeC ty; mcode print_string lp1; mcode print_string star; fn();
- mcode print_string rp1; mcode print_string lp2;
- parameter_list params; mcode print_string rp2
-
-and print_function_type (ty,lp1,params,rp1) fn =
- print_option typeC ty; fn(); mcode print_string lp1;
- parameter_list params; mcode print_string rp1
-
-and typeC t =
- print_context t
- (function _ ->
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) ->
- mcode U.const_vol cv; print_string " "; typeC ty
- | Ast0.BaseType(ty,strings) ->
- List.iter (function s -> mcode print_string s; print_string " ")
- strings
- | Ast0.Signed(sgn,ty) -> mcode U.sign sgn; print_option typeC ty
- | Ast0.Pointer(ty,star) -> typeC ty; mcode print_string star
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> ())
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1) (function _ -> ())
- | Ast0.Array(ty,lb,size,rb) ->
- typeC ty; mcode print_string lb; print_option expression size;
- mcode print_string rb
- | Ast0.EnumName(kind,name) -> mcode print_string kind; print_string " ";
- ident name
- | Ast0.StructUnionName(kind,name) ->
- mcode U.structUnion kind;
- print_option (function x -> ident x; print_string " ") name
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- typeC ty; mcode print_string lb;
- dots force_newline declaration decls;
- mcode print_string rb
- | Ast0.TypeName(name)-> mcode print_string name; print_string " "
- | Ast0.MetaType(name,_)-> mcode print_meta name; print_string " "
- | Ast0.DisjType(lp,types,mids,rp) ->
- print_string "\n"; mcode print_string lp; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- typeC types;
- print_string "\n"; mcode print_string rp
- | Ast0.OptType(ty) -> print_string "?"; typeC ty
- | Ast0.UniqueType(ty) -> print_string "!"; typeC ty)
-
-(* --------------------------------------------------------------------- *)
-(* Variable declaration *)
-(* Even if the Cocci program specifies a list of declarations, they are
- split out into multiple declarations of a single variable each. *)
-
-and print_named_type ty id =
- match Ast0.unwrap ty with
- Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- print_function_pointer (ty,lp1,star,rp1,lp2,params,rp2)
- (function _ -> print_string " "; ident id)
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- print_function_type (ty,lp1,params,rp1)
- (function _ -> print_string " "; ident id)
- | Ast0.Array(ty,lb,size,rb) ->
- let rec loop ty k =
- match Ast0.unwrap ty with
- Ast0.Array(ty,lb,size,rb) ->
- loop ty
- (function _ ->
- k ();
- mcode print_string lb;
- print_option expression size;
- mcode print_string rb)
- | _ -> typeC ty; ident id; k () in
- loop ty (function _ -> ())
- | _ -> typeC ty; ident id
-
-and declaration d =
- print_context d
- (function _ ->
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- print_option (mcode U.storage) stg;
- print_named_type ty id;
- print_string " ";
- mcode print_string eq; print_string " "; initialiser ini;
- mcode print_string sem
- | Ast0.UnInit(stg,ty,id,sem) ->
- print_option (mcode U.storage) stg; print_named_type ty id;
- mcode print_string sem
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- ident name; mcode print_string_box lp;
- let _ = dots (function _ -> ()) expression args in
- close_box(); mcode print_string rp; mcode print_string sem
- | Ast0.TyDecl(ty,sem) -> typeC ty; mcode print_string sem
- | Ast0.Typedef(stg,ty,id,sem) ->
- mcode print_string stg; typeC ty; typeC id;
- mcode print_string sem
- | Ast0.DisjDecl(_,decls,_,_) ->
- print_string "\n("; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- declaration decls;
- print_string "\n)"
- | Ast0.Ddots(dots,Some whencode) ->
- mcode print_string dots; print_string " when != ";
- declaration whencode
- | Ast0.Ddots(dots,None) -> mcode print_string dots
- | Ast0.OptDecl(decl) -> print_string "?"; declaration decl
- | Ast0.UniqueDecl(decl) -> print_string "!"; declaration decl)
-
-and declaration_dots l = dots (function _ -> ()) declaration l
-
-(* --------------------------------------------------------------------- *)
-(* Initialiser *)
-
-and initialiser i =
- print_context i
- (function _ ->
- match Ast0.unwrap i with
- Ast0.MetaInit(name,_)-> mcode print_meta name; print_string " "
- | Ast0.InitExpr(exp) -> expression exp
- | Ast0.InitList(lb,initlist,rb) ->
- mcode print_string lb; open_box 0;
- let _ = dots (function _ -> ()) initialiser initlist in
- close_box(); mcode print_string rb
- | Ast0.InitGccExt(designators,eq,ini) ->
- List.iter designator designators; print_string " ";
- mcode print_string eq; print_string " "; initialiser ini
- | Ast0.InitGccName(name,eq,ini) ->
- ident name; mcode print_string eq; initialiser ini
- | Ast0.IComma(cm) -> mcode print_string cm; force_newline()
- | Ast0.Idots(d,Some whencode) ->
- mcode print_string d; print_string " WHEN != ";
- initialiser whencode
- | Ast0.Idots(d,None) -> mcode print_string d
- | Ast0.OptIni(ini) -> print_string "?"; initialiser ini
- | Ast0.UniqueIni(ini) -> print_string "!"; initialiser ini)
-
-and designator = function
- Ast0.DesignatorField(dot,id) -> mcode print_string dot; ident id
- | Ast0.DesignatorIndex(lb,exp,rb) ->
- mcode print_string lb; expression exp; mcode print_string rb
- | Ast0.DesignatorRange(lb,min,dots,max,rb) ->
- mcode print_string lb; expression min; mcode print_string dots;
- expression max; mcode print_string rb
-
-and initialiser_list l = dots (function _ -> ()) initialiser l
-
-(* --------------------------------------------------------------------- *)
-(* Parameter *)
-
-and parameterTypeDef p =
- print_context p
- (function _ ->
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> typeC ty
- | Ast0.Param(ty,Some id) -> print_named_type ty id
- | Ast0.Param(ty,None) -> typeC ty
- | Ast0.MetaParam(name,_) -> mcode print_meta name
- | Ast0.MetaParamList(name,_,_) -> mcode print_meta name
- | Ast0.PComma(cm) -> mcode print_string cm; print_space()
- | Ast0.Pdots(dots) -> mcode print_string dots
- | Ast0.Pcircles(dots) -> mcode print_string dots
- | Ast0.OptParam(param) -> print_string "?"; parameterTypeDef param
- | Ast0.UniqueParam(param) -> print_string "!"; parameterTypeDef param)
-
-and parameter_list l = dots (function _ -> ()) parameterTypeDef l
-
-(* --------------------------------------------------------------------- *)
-(* Top-level code *)
-
-and statement arity s =
- print_context s
- (function _ ->
- match Ast0.unwrap s with
- Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
- print_string arity;
- List.iter print_fninfo fninfo;
- ident name; mcode print_string_box lp;
- parameter_list params; close_box(); mcode print_string rp;
- print_string " ";
- print_string arity; mcode print_string lbrace; start_block();
- dots force_newline (statement arity) body;
- end_block(); print_string arity; mcode print_string rbrace
- | Ast0.Decl(_,decl) -> print_string arity; declaration decl
- | Ast0.Seq(lbrace,body,rbrace) ->
- print_string arity; mcode print_string lbrace; start_block();
- dots force_newline (statement arity) body;
- end_block(); print_string arity; mcode print_string rbrace
- | Ast0.ExprStatement(exp,sem) ->
- print_string arity; expression exp; mcode print_string sem
- | Ast0.IfThen(iff,lp,exp,rp,branch1,(info,aft)) ->
- print_string arity;
- mcode print_string iff; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " ";
- statement arity branch1;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,(info,aft)) ->
- print_string arity;
- mcode print_string iff; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " ";
- statement arity branch1;
- print_string arity; mcode print_string els; print_string " ";
- statement arity branch2;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.While(whl,lp,exp,rp,body,(info,aft)) ->
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp; print_string " ";
- statement arity body;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.Do(d,body,whl,lp,exp,rp,sem) ->
- print_string arity; mcode print_string d; print_string " ";
- statement arity body;
- print_string arity;
- mcode print_string whl; print_string " "; mcode print_string_box lp;
- expression exp; close_box(); mcode print_string rp;
- mcode print_string sem
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,(info,aft)) ->
- print_string arity;
- mcode print_string fr; mcode print_string_box lp;
- print_option expression e1; mcode print_string sem1;
- print_option expression e2; mcode print_string sem2;
- print_option expression e3; close_box();
- mcode print_string rp; print_string " "; statement arity body;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.Iterator(nm,lp,args,rp,body,(info,aft)) ->
- print_string arity;
- ident nm; print_string " "; mcode print_string_box lp;
- let _ = dots (function _ -> ()) expression args in
- close_box(); mcode print_string rp; print_string " ";
- statement arity body;
- mcode (function _ -> ()) ((),(),info,aft,ref Ast0.NoMetaPos)
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- print_string arity;
- mcode print_string switch; print_string " ";
- mcode print_string_box lp; expression exp; close_box();
- mcode print_string rp; print_string " "; mcode print_string lb;
- dots force_newline (case_line arity) cases;
- mcode print_string rb
- | Ast0.Break(br,sem) ->
- print_string arity; mcode print_string br; mcode print_string sem
- | Ast0.Continue(cont,sem) ->
- print_string arity; mcode print_string cont; mcode print_string sem
- | Ast0.Label(l,dd) -> ident l; print_string ":"
- | Ast0.Goto(goto,l,sem) ->
- mcode print_string goto; ident l; mcode print_string sem
- | Ast0.Return(ret,sem) ->
- print_string arity; mcode print_string ret; mcode print_string sem
- | Ast0.ReturnExpr(ret,exp,sem) ->
- print_string arity; mcode print_string ret; print_string " ";
- expression exp; mcode print_string sem
- | Ast0.MetaStmt(name,pure) ->
- print_string arity; mcode print_meta name;(*
- print_string "^";
- (match pure with
- Ast0.Pure -> print_string "pure"
- | Ast0.Impure -> print_string "impure"
- | Ast0.Context -> print_string "context"
- | Ast0.PureContext -> print_string "pure_context")*)
- | Ast0.MetaStmtList(name,_) ->
- print_string arity; mcode print_meta name
- | Ast0.Disj(_,statement_dots_list,_,_) ->
- print_string arity;
- print_string "\n("; force_newline();
- print_between
- (function _ -> print_string "\n|"; force_newline())
- (dots force_newline (statement arity))
- statement_dots_list;
- print_string "\n)"
- | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
- print_string arity;
- mcode print_string starter;
- open_box 0;
- List.iter
- (whencode (dots force_newline (statement "")) (statement ""))
- whn;
- close_box();
- start_block();
- dots force_newline (statement arity) stmt_dots;
- end_block();
- mcode print_string ender
- | Ast0.Exp(exp) -> print_string arity; expression exp
- | Ast0.TopExp(exp) -> print_string arity; expression exp
- | Ast0.Ty(ty) -> print_string arity; typeC ty
- | Ast0.TopInit(init) -> initialiser init
- | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
- print_string arity; mcode print_string d;
- List.iter
- (whencode (dots force_newline (statement "")) (statement ""))
- whn
- | Ast0.Include(inc,s) ->
- mcode print_string inc; print_string " "; mcode U.inc_file s
- | Ast0.Define(def,id,params,body) ->
- mcode print_string def; print_string " "; ident id;
- print_define_parameters params;
- print_string " ";
- dots force_newline (statement arity) body
- | Ast0.OptStm(re) -> statement "?" re
- | Ast0.UniqueStm(re) -> statement "!" re)
-
-and print_define_parameters params =
- match Ast0.unwrap params with
- Ast0.NoParams -> ()
- | Ast0.DParams(lp,params,rp) ->
- mcode print_string lp;
- dots (function _ -> ()) print_define_param params; mcode print_string rp
-
-and print_define_param param =
- match Ast0.unwrap param with
- Ast0.DParam(id) -> ident id
- | Ast0.DPComma(comma) -> mcode print_string comma
- | Ast0.DPdots(dots) -> mcode print_string dots
- | Ast0.DPcircles(circles) -> mcode print_string circles
- | Ast0.OptDParam(dp) -> print_string "?"; print_define_param dp
- | Ast0.UniqueDParam(dp) -> print_string "!"; print_define_param dp
-
-and print_fninfo = function
- Ast0.FStorage(stg) -> mcode U.storage stg
- | Ast0.FType(ty) -> typeC ty
- | Ast0.FInline(inline) -> mcode print_string inline
- | Ast0.FAttr(attr) -> mcode print_string attr
-
-and whencode notfn alwaysfn = function
- Ast0.WhenNot a ->
- print_string " WHEN != "; open_box 0; notfn a; close_box()
- | Ast0.WhenAlways a ->
- print_string " WHEN = "; open_box 0; alwaysfn a; close_box()
- | Ast0.WhenModifier x -> print_string " WHEN "; U.print_when_modif x
- | Ast0.WhenNotTrue a ->
- print_string " WHEN != TRUE "; open_box 0; expression a; close_box()
- | Ast0.WhenNotFalse a ->
- print_string " WHEN != FALSE "; open_box 0; expression a; close_box()
-
-and case_line arity c =
- print_context c
- (function _ ->
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- print_string arity;
- mcode print_string def; mcode print_string colon; print_string " ";
- dots force_newline (statement arity) code
- | Ast0.Case(case,exp,colon,code) ->
- print_string arity;
- mcode print_string case; print_string " "; expression exp;
- mcode print_string colon; print_string " ";
- dots force_newline (statement arity) code
- | Ast0.OptCase(case) -> case_line "?" case)
-
-and statement_dots l = dots (function _ -> ()) (statement "") l
-and case_dots l = dots (function _ -> ()) (case_line "") l
-
-(* --------------------------------------------------------------------- *)
-(* Top level code *)
-
-let top_level t =
- print_context t
- (function _ ->
- match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- print_string "--- "; mcode print_string old_file; force_newline();
- print_string "+++ "; mcode print_string new_file
- | Ast0.DECL(stmt) -> statement "" stmt
- | Ast0.CODE(stmt_dots) ->
- dots force_newline (statement "") stmt_dots
- | Ast0.ERRORWORDS(exps) ->
- print_string "error words = [";
- print_between (function _ -> print_string ", ") expression exps;
- print_string "]"
- | Ast0.OTHER(s) ->
- print_string "OTHER("; statement "" s; print_string ")")
-
-let rule =
- print_between (function _ -> force_newline(); force_newline()) top_level
-
-let unparse_anything x =
- let q = !quiet in
- quiet := true;
- (match x with
- Ast0.DotsExprTag(d) ->
- print_string "ExpDots:"; force_newline();
- expression_dots d
- | Ast0.DotsParamTag(d) ->
- parameter_list d
- | Ast0.DotsInitTag(d) ->
- initialiser_list d
- | Ast0.DotsStmtTag(d) ->
- print_string "StmDots:"; force_newline();
- statement_dots d
- | Ast0.DotsDeclTag(d) ->
- declaration_dots d
- | Ast0.DotsCaseTag(d) ->
- case_dots d
- | Ast0.IdentTag(d) ->
- ident d
- | Ast0.ExprTag(d) | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
- print_string "Exp:"; force_newline();
- expression d
- | Ast0.TypeCTag(d) ->
- typeC d
- | Ast0.ParamTag(d) ->
- parameterTypeDef d
- | Ast0.InitTag(d) ->
- initialiser d
- | Ast0.DeclTag(d) ->
- declaration d
- | Ast0.StmtTag(d) ->
- print_string "Stm:"; force_newline();
- statement "" d
- | Ast0.CaseLineTag(d) ->
- case_line "" d
- | Ast0.TopTag(d) ->
- top_level d
- | Ast0.IsoWhenTag(x) -> U.print_when_modif x
- | Ast0.IsoWhenTTag(e) -> expression e
- | Ast0.IsoWhenFTag(e) -> expression e
- | Ast0.MetaPosTag(var) -> meta_pos var);
- quiet := q;
- print_newline()
-
-let unparse x =
- print_string "\n@@\n@@";
- force_newline();
- force_newline();
- rule x;
- print_newline()
-
-let unparse_to_string x = Common.format_to_string (function _ -> unparse x)
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Generic traversal: combiner *)
-(* parameters:
- combining function
- treatment of: mcode, identifiers, expressions, fullTypes, types,
- declarations, statements, toplevels
- default value for options *)
-
-type 'a combiner =
- {combiner_ident : Ast.ident -> 'a;
- combiner_expression : Ast.expression -> 'a;
- combiner_fullType : Ast.fullType -> 'a;
- combiner_typeC : Ast.typeC -> 'a;
- combiner_declaration : Ast.declaration -> 'a;
- combiner_initialiser : Ast.initialiser -> 'a;
- combiner_parameter : Ast.parameterTypeDef -> 'a;
- combiner_parameter_list : Ast.parameter_list -> 'a;
- combiner_rule_elem : Ast.rule_elem -> 'a;
- combiner_statement : Ast.statement -> 'a;
- combiner_case_line : Ast.case_line -> 'a;
- combiner_top_level : Ast.top_level -> 'a;
- combiner_anything : Ast.anything -> 'a;
- combiner_expression_dots : Ast.expression Ast.dots -> 'a;
- combiner_statement_dots : Ast.statement Ast.dots -> 'a;
- combiner_declaration_dots : Ast.declaration Ast.dots -> 'a}
-
-type ('mc,'a) cmcode = 'a combiner -> 'mc Ast_cocci.mcode -> 'a
-type ('cd,'a) ccode = 'a combiner -> ('cd -> 'a) -> 'cd -> 'a
-
-
-let combiner bind option_default
- meta_mcodefn string_mcodefn const_mcodefn assign_mcodefn fix_mcodefn
- unary_mcodefn binary_mcodefn
- cv_mcodefn sign_mcodefn struct_mcodefn storage_mcodefn
- inc_file_mcodefn
- expdotsfn paramdotsfn stmtdotsfn decldotsfn
- identfn exprfn ftfn tyfn initfn paramfn declfn rulefn stmtfn casefn
- topfn anyfn =
- let multibind l =
- let rec loop = function
- [] -> option_default
- | [x] -> x
- | x::xs -> bind x (loop xs) in
- loop l in
- let get_option f = function
- Some x -> f x
- | None -> option_default in
-
- let rec meta_mcode x = meta_mcodefn all_functions x
- and string_mcode x = string_mcodefn all_functions x
- and const_mcode x = const_mcodefn all_functions x
- and assign_mcode x = assign_mcodefn all_functions x
- and fix_mcode x = fix_mcodefn all_functions x
- and unary_mcode x = unary_mcodefn all_functions x
- and binary_mcode x = binary_mcodefn all_functions x
- and cv_mcode x = cv_mcodefn all_functions x
- and sign_mcode x = sign_mcodefn all_functions x
- and struct_mcode x = struct_mcodefn all_functions x
- and storage_mcode x = storage_mcodefn all_functions x
- and inc_file_mcode x = inc_file_mcodefn all_functions x
-
- and expression_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map expression l) in
- expdotsfn all_functions k d
-
- and parameter_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map parameterTypeDef l) in
- paramdotsfn all_functions k d
-
- and statement_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map statement l) in
- stmtdotsfn all_functions k d
-
- and declaration_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map declaration l) in
- decldotsfn all_functions k d
-
- and ident i =
- let k i =
- match Ast.unwrap i with
- Ast.Id(name) -> string_mcode name
- | Ast.MetaId(name,_,_,_) -> meta_mcode name
- | Ast.MetaFunc(name,_,_,_) -> meta_mcode name
- | Ast.MetaLocalFunc(name,_,_,_) -> meta_mcode name
- | Ast.OptIdent(id) -> ident id
- | Ast.UniqueIdent(id) -> ident id in
- identfn all_functions k i
-
- and expression e =
- let k e =
- match Ast.unwrap e with
- Ast.Ident(id) -> ident id
- | Ast.Constant(const) -> const_mcode const
- | Ast.FunCall(fn,lp,args,rp) ->
- multibind [expression fn; string_mcode lp; expression_dots args;
- string_mcode rp]
- | Ast.Assignment(left,op,right,simple) ->
- multibind [expression left; assign_mcode op; expression right]
- | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
- multibind [expression exp1; string_mcode why;
- get_option expression exp2; string_mcode colon;
- expression exp3]
- | Ast.Postfix(exp,op) -> bind (expression exp) (fix_mcode op)
- | Ast.Infix(exp,op) -> bind (fix_mcode op) (expression exp)
- | Ast.Unary(exp,op) -> bind (unary_mcode op) (expression exp)
- | Ast.Binary(left,op,right) ->
- multibind [expression left; binary_mcode op; expression right]
- | Ast.Nested(left,op,right) ->
- multibind [expression left; binary_mcode op; expression right]
- | Ast.Paren(lp,exp,rp) ->
- multibind [string_mcode lp; expression exp; string_mcode rp]
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- multibind
- [expression exp1; string_mcode lb; expression exp2;
- string_mcode rb]
- | Ast.RecordAccess(exp,pt,field) ->
- multibind [expression exp; string_mcode pt; ident field]
- | Ast.RecordPtAccess(exp,ar,field) ->
- multibind [expression exp; string_mcode ar; ident field]
- | Ast.Cast(lp,ty,rp,exp) ->
- multibind
- [string_mcode lp; fullType ty; string_mcode rp; expression exp]
- | Ast.SizeOfExpr(szf,exp) ->
- multibind [string_mcode szf; expression exp]
- | Ast.SizeOfType(szf,lp,ty,rp) ->
- multibind
- [string_mcode szf; string_mcode lp; fullType ty; string_mcode rp]
- | Ast.TypeExp(ty) -> fullType ty
- | Ast.MetaErr(name,_,_,_)
- | Ast.MetaExpr(name,_,_,_,_,_)
- | Ast.MetaExprList(name,_,_,_) -> meta_mcode name
- | Ast.EComma(cm) -> string_mcode cm
- | Ast.DisjExpr(exp_list) -> multibind (List.map expression exp_list)
- | Ast.NestExpr(expr_dots,whencode,multi) ->
- bind (expression_dots expr_dots) (get_option expression whencode)
- | Ast.Edots(dots,whencode) | Ast.Ecircles(dots,whencode)
- | Ast.Estars(dots,whencode) ->
- bind (string_mcode dots) (get_option expression whencode)
- | Ast.OptExp(exp) | Ast.UniqueExp(exp) ->
- expression exp in
- exprfn all_functions k e
-
- and fullType ft =
- let k ft =
- match Ast.unwrap ft with
- Ast.Type(cv,ty) -> bind (get_option cv_mcode cv) (typeC ty)
- | Ast.DisjType(types) -> multibind (List.map fullType types)
- | Ast.OptType(ty) -> fullType ty
- | Ast.UniqueType(ty) -> fullType ty in
- ftfn all_functions k ft
-
- and function_pointer (ty,lp1,star,rp1,lp2,params,rp2) extra =
- (* have to put the treatment of the identifier into the right position *)
- multibind
- ([fullType ty; string_mcode lp1; string_mcode star] @ extra @
- [string_mcode rp1;
- string_mcode lp2; parameter_dots params; string_mcode rp2])
-
- and function_type (ty,lp1,params,rp1) extra =
- (* have to put the treatment of the identifier into the right position *)
- multibind
- ([get_option fullType ty] @ extra @
- [string_mcode lp1; parameter_dots params; string_mcode rp1])
-
- and array_type (ty,lb,size,rb) extra =
- multibind
- ([fullType ty] @ extra @
- [string_mcode lb; get_option expression size; string_mcode rb])
-
- and typeC ty =
- let k ty =
- match Ast.unwrap ty with
- Ast.BaseType(ty,strings) -> multibind (List.map string_mcode strings)
- | Ast.SignedT(sgn,ty) -> bind (sign_mcode sgn) (get_option typeC ty)
- | Ast.Pointer(ty,star) ->
- bind (fullType ty) (string_mcode star)
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- function_pointer (ty,lp1,star,rp1,lp2,params,rp2) []
- | Ast.FunctionType (_,ty,lp1,params,rp1) ->
- function_type (ty,lp1,params,rp1) []
- | Ast.Array(ty,lb,size,rb) -> array_type (ty,lb,size,rb) []
- | Ast.EnumName(kind,name) -> bind (string_mcode kind) (ident name)
- | Ast.StructUnionName(kind,name) ->
- bind (struct_mcode kind) (get_option ident name)
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- multibind
- [fullType ty; string_mcode lb; declaration_dots decls;
- string_mcode rb]
- | Ast.TypeName(name) -> string_mcode name
- | Ast.MetaType(name,_,_) -> meta_mcode name in
- tyfn all_functions k ty
-
- and named_type ty id =
- match Ast.unwrap ty with
- Ast.Type(None,ty1) ->
- (match Ast.unwrap ty1 with
- Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- function_pointer (ty,lp1,star,rp1,lp2,params,rp2) [ident id]
- | Ast.FunctionType(_,ty,lp1,params,rp1) ->
- function_type (ty,lp1,params,rp1) [ident id]
- | Ast.Array(ty,lb,size,rb) -> array_type (ty,lb,size,rb) [ident id]
- | _ -> bind (fullType ty) (ident id))
- | _ -> bind (fullType ty) (ident id)
-
- and declaration d =
- let k d =
- match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- bind (get_option storage_mcode stg)
- (bind (named_type ty id)
- (multibind
- [string_mcode eq; initialiser ini; string_mcode sem]))
- | Ast.UnInit(stg,ty,id,sem) ->
- bind (get_option storage_mcode stg)
- (bind (named_type ty id) (string_mcode sem))
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- multibind
- [ident name; string_mcode lp; expression_dots args;
- string_mcode rp; string_mcode sem]
- | Ast.TyDecl(ty,sem) -> bind (fullType ty) (string_mcode sem)
- | Ast.Typedef(stg,ty,id,sem) ->
- bind (string_mcode stg)
- (bind (fullType ty) (bind (typeC id) (string_mcode sem)))
- | Ast.DisjDecl(decls) -> multibind (List.map declaration decls)
- | Ast.Ddots(dots,whencode) ->
- bind (string_mcode dots) (get_option declaration whencode)
- | Ast.MetaDecl(name,_,_) -> meta_mcode name
- | Ast.OptDecl(decl) -> declaration decl
- | Ast.UniqueDecl(decl) -> declaration decl in
- declfn all_functions k d
-
- and initialiser i =
- let k i =
- match Ast.unwrap i with
- Ast.InitExpr(exp) -> expression exp
- | Ast.InitList(lb,initlist,rb,whencode) ->
- multibind
- [string_mcode lb;
- multibind (List.map initialiser initlist);
- string_mcode rb;
- multibind (List.map initialiser whencode)]
- | Ast.InitGccDotName(dot,name,eq,ini) ->
- multibind
- [string_mcode dot; ident name; string_mcode eq; initialiser ini]
- | Ast.InitGccName(name,eq,ini) ->
- multibind [ident name; string_mcode eq; initialiser ini]
- | Ast.InitGccIndex(lb,exp,rb,eq,ini) ->
- multibind
- [string_mcode lb; expression exp; string_mcode rb;
- string_mcode eq; initialiser ini]
- | Ast.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- multibind
- [string_mcode lb; expression exp1; string_mcode dots;
- expression exp2; string_mcode rb; string_mcode eq;
- initialiser ini]
- | Ast.IComma(cm) -> string_mcode cm
- | Ast.OptIni(i) -> initialiser i
- | Ast.UniqueIni(i) -> initialiser i in
- initfn all_functions k i
-
- and parameterTypeDef p =
- let k p =
- match Ast.unwrap p with
- Ast.VoidParam(ty) -> fullType ty
- | Ast.Param(ty,Some id) -> named_type ty id
- | Ast.Param(ty,None) -> fullType ty
- | Ast.MetaParam(name,_,_) -> meta_mcode name
- | Ast.MetaParamList(name,_,_,_) -> meta_mcode name
- | Ast.PComma(cm) -> string_mcode cm
- | Ast.Pdots(dots) -> string_mcode dots
- | Ast.Pcircles(dots) -> string_mcode dots
- | Ast.OptParam(param) -> parameterTypeDef param
- | Ast.UniqueParam(param) -> parameterTypeDef param in
- paramfn all_functions k p
-
- and rule_elem re =
- let k re =
- match Ast.unwrap re with
- Ast.FunHeader(_,_,fi,name,lp,params,rp) ->
- multibind
- ((List.map fninfo fi) @
- [ident name;string_mcode lp;parameter_dots params;
- string_mcode rp])
- | Ast.Decl(_,_,decl) -> declaration decl
- | Ast.SeqStart(brace) -> string_mcode brace
- | Ast.SeqEnd(brace) -> string_mcode brace
- | Ast.ExprStatement(exp,sem) ->
- bind (expression exp) (string_mcode sem)
- | Ast.IfHeader(iff,lp,exp,rp) ->
- multibind [string_mcode iff; string_mcode lp; expression exp;
- string_mcode rp]
- | Ast.Else(els) -> string_mcode els
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- multibind [string_mcode whl; string_mcode lp; expression exp;
- string_mcode rp]
- | Ast.DoHeader(d) -> string_mcode d
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- multibind [string_mcode whl; string_mcode lp; expression exp;
- string_mcode rp; string_mcode sem]
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- multibind [string_mcode fr; string_mcode lp;
- get_option expression e1; string_mcode sem1;
- get_option expression e2; string_mcode sem2;
- get_option expression e3; string_mcode rp]
- | Ast.IteratorHeader(nm,lp,args,rp) ->
- multibind [ident nm; string_mcode lp;
- expression_dots args; string_mcode rp]
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- multibind [string_mcode switch; string_mcode lp; expression exp;
- string_mcode rp]
- | Ast.Break(br,sem) -> bind (string_mcode br) (string_mcode sem)
- | Ast.Continue(cont,sem) -> bind (string_mcode cont) (string_mcode sem)
- | Ast.Label(l,dd) -> bind (ident l) (string_mcode dd)
- | Ast.Goto(goto,l,sem) ->
- bind (string_mcode goto) (bind (ident l) (string_mcode sem))
- | Ast.Return(ret,sem) -> bind (string_mcode ret) (string_mcode sem)
- | Ast.ReturnExpr(ret,exp,sem) ->
- multibind [string_mcode ret; expression exp; string_mcode sem]
- | Ast.MetaStmt(name,_,_,_) -> meta_mcode name
- | Ast.MetaStmtList(name,_,_) -> meta_mcode name
- | Ast.MetaRuleElem(name,_,_) -> meta_mcode name
- | Ast.Exp(exp) -> expression exp
- | Ast.TopExp(exp) -> expression exp
- | Ast.Ty(ty) -> fullType ty
- | Ast.TopInit(init) -> initialiser init
- | Ast.Include(inc,name) -> bind (string_mcode inc) (inc_file_mcode name)
- | Ast.DefineHeader(def,id,params) ->
- multibind [string_mcode def; ident id; define_parameters params]
- | Ast.Default(def,colon) -> bind (string_mcode def) (string_mcode colon)
- | Ast.Case(case,exp,colon) ->
- multibind [string_mcode case; expression exp; string_mcode colon]
- | Ast.DisjRuleElem(res) -> multibind (List.map rule_elem res) in
- rulefn all_functions k re
-
- (* not parameterizable for now... *)
- and define_parameters p =
- let k p =
- match Ast.unwrap p with
- Ast.NoParams -> option_default
- | Ast.DParams(lp,params,rp) ->
- multibind
- [string_mcode lp; define_param_dots params; string_mcode rp] in
- k p
-
- and define_param_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map define_param l) in
- k d
-
- and define_param p =
- let k p =
- match Ast.unwrap p with
- Ast.DParam(id) -> ident id
- | Ast.DPComma(comma) -> string_mcode comma
- | Ast.DPdots(d) -> string_mcode d
- | Ast.DPcircles(c) -> string_mcode c
- | Ast.OptDParam(dp) -> define_param dp
- | Ast.UniqueDParam(dp) -> define_param dp in
- k p
-
- (* discard the result, because the statement is assumed to be already
- represented elsewhere in the code *)
- and process_bef_aft s =
- match Ast.get_dots_bef_aft s with
- Ast.NoDots -> ()
- | Ast.DroppingBetweenDots(stm,ind) -> let _ = statement stm in ()
- | Ast.AddingBetweenDots(stm,ind) -> let _ = statement stm in ()
-
- and statement s =
- process_bef_aft s;
- let k s =
- match Ast.unwrap s with
- Ast.Seq(lbrace,decls,body,rbrace) ->
- multibind [rule_elem lbrace; statement_dots decls;
- statement_dots body; rule_elem rbrace]
- | Ast.IfThen(header,branch,_) ->
- multibind [rule_elem header; statement branch]
- | Ast.IfThenElse(header,branch1,els,branch2,_) ->
- multibind [rule_elem header; statement branch1; rule_elem els;
- statement branch2]
- | Ast.While(header,body,_) ->
- multibind [rule_elem header; statement body]
- | Ast.Do(header,body,tail) ->
- multibind [rule_elem header; statement body; rule_elem tail]
- | Ast.For(header,body,_) -> multibind [rule_elem header; statement body]
- | Ast.Iterator(header,body,_) ->
- multibind [rule_elem header; statement body]
- | Ast.Switch(header,lb,cases,rb) ->
- multibind [rule_elem header;rule_elem lb;
- multibind (List.map case_line cases);
- rule_elem rb]
- | Ast.Atomic(re) -> rule_elem re
- | Ast.Disj(stmt_dots_list) ->
- multibind (List.map statement_dots stmt_dots_list)
- | Ast.Nest(stmt_dots,whn,_,_,_) ->
- bind (statement_dots stmt_dots)
- (multibind (List.map (whencode statement_dots statement) whn))
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- multibind [rule_elem header; rule_elem lbrace;
- statement_dots decls; statement_dots body;
- rule_elem rbrace]
- | Ast.Define(header,body) ->
- bind (rule_elem header) (statement_dots body)
- | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
- bind (string_mcode d)
- (multibind (List.map (whencode statement_dots statement) whn))
- | Ast.OptStm(stmt) | Ast.UniqueStm(stmt) ->
- statement stmt in
- stmtfn all_functions k s
-
- and fninfo = function
- Ast.FStorage(stg) -> storage_mcode stg
- | Ast.FType(ty) -> fullType ty
- | Ast.FInline(inline) -> string_mcode inline
- | Ast.FAttr(attr) -> string_mcode attr
-
- and whencode notfn alwaysfn = function
- Ast.WhenNot a -> notfn a
- | Ast.WhenAlways a -> alwaysfn a
- | Ast.WhenModifier(_) -> option_default
- | Ast.WhenNotTrue(e) -> rule_elem e
- | Ast.WhenNotFalse(e) -> rule_elem e
-
- and case_line c =
- let k c =
- match Ast.unwrap c with
- Ast.CaseLine(header,code) ->
- bind (rule_elem header) (statement_dots code)
- | Ast.OptCase(case) -> case_line case in
- casefn all_functions k c
-
- and top_level t =
- let k t =
- match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) ->
- bind (string_mcode old_file) (string_mcode new_file)
- | Ast.DECL(stmt) -> statement stmt
- | Ast.CODE(stmt_dots) -> statement_dots stmt_dots
- | Ast.ERRORWORDS(exps) -> multibind (List.map expression exps) in
- topfn all_functions k t
-
- and anything a =
- let k = function
- (*in many cases below, the thing is not even mcode, so we do nothing*)
- Ast.FullTypeTag(ft) -> fullType ft
- | Ast.BaseTypeTag(bt) -> option_default
- | Ast.StructUnionTag(su) -> option_default
- | Ast.SignTag(sgn) -> option_default
- | Ast.IdentTag(id) -> ident id
- | Ast.ExpressionTag(exp) -> expression exp
- | Ast.ConstantTag(cst) -> option_default
- | Ast.UnaryOpTag(unop) -> option_default
- | Ast.AssignOpTag(asgnop) -> option_default
- | Ast.FixOpTag(fixop) -> option_default
- | Ast.BinaryOpTag(binop) -> option_default
- | Ast.ArithOpTag(arithop) -> option_default
- | Ast.LogicalOpTag(logop) -> option_default
- | Ast.DeclarationTag(decl) -> declaration decl
- | Ast.InitTag(ini) -> initialiser ini
- | Ast.StorageTag(stg) -> option_default
- | Ast.IncFileTag(stg) -> option_default
- | Ast.Rule_elemTag(rule) -> rule_elem rule
- | Ast.StatementTag(rule) -> statement rule
- | Ast.CaseLineTag(case) -> case_line case
- | Ast.ConstVolTag(cv) -> option_default
- | Ast.Token(tok,info) -> option_default
- | Ast.Code(cd) -> top_level cd
- | Ast.ExprDotsTag(ed) -> expression_dots ed
- | Ast.ParamDotsTag(pd) -> parameter_dots pd
- | Ast.StmtDotsTag(sd) -> statement_dots sd
- | Ast.DeclDotsTag(sd) -> declaration_dots sd
- | Ast.TypeCTag(ty) -> typeC ty
- | Ast.ParamTag(param) -> parameterTypeDef param
- | Ast.SgrepStartTag(tok) -> option_default
- | Ast.SgrepEndTag(tok) -> option_default in
- anyfn all_functions k a
-
- and all_functions =
- {combiner_ident = ident;
- combiner_expression = expression;
- combiner_fullType = fullType;
- combiner_typeC = typeC;
- combiner_declaration = declaration;
- combiner_initialiser = initialiser;
- combiner_parameter = parameterTypeDef;
- combiner_parameter_list = parameter_dots;
- combiner_rule_elem = rule_elem;
- combiner_statement = statement;
- combiner_case_line = case_line;
- combiner_top_level = top_level;
- combiner_anything = anything;
- combiner_expression_dots = expression_dots;
- combiner_statement_dots = statement_dots;
- combiner_declaration_dots = declaration_dots} in
- all_functions
-
-(* ---------------------------------------------------------------------- *)
-
-type 'a inout = 'a -> 'a (* for specifying the type of rebuilder *)
-
-type rebuilder =
- {rebuilder_ident : Ast.ident inout;
- rebuilder_expression : Ast.expression inout;
- rebuilder_fullType : Ast.fullType inout;
- rebuilder_typeC : Ast.typeC inout;
- rebuilder_declaration : Ast.declaration inout;
- rebuilder_initialiser : Ast.initialiser inout;
- rebuilder_parameter : Ast.parameterTypeDef inout;
- rebuilder_parameter_list : Ast.parameter_list inout;
- rebuilder_statement : Ast.statement inout;
- rebuilder_case_line : Ast.case_line inout;
- rebuilder_rule_elem : Ast.rule_elem inout;
- rebuilder_top_level : Ast.top_level inout;
- rebuilder_expression_dots : Ast.expression Ast.dots inout;
- rebuilder_statement_dots : Ast.statement Ast.dots inout;
- rebuilder_declaration_dots : Ast.declaration Ast.dots inout;
- rebuilder_define_param_dots : Ast.define_param Ast.dots inout;
- rebuilder_define_param : Ast.define_param inout;
- rebuilder_define_parameters : Ast.define_parameters inout;
- rebuilder_anything : Ast.anything inout}
-
-type 'mc rmcode = 'mc Ast.mcode inout
-type 'cd rcode = rebuilder -> ('cd inout) -> 'cd inout
-
-
-let rebuilder
- meta_mcode string_mcode const_mcode assign_mcode fix_mcode unary_mcode
- binary_mcode cv_mcode sign_mcode struct_mcode storage_mcode
- inc_file_mcode
- expdotsfn paramdotsfn stmtdotsfn decldotsfn
- identfn exprfn ftfn tyfn initfn paramfn declfn rulefn stmtfn casefn
- topfn anyfn =
- let get_option f = function
- Some x -> Some (f x)
- | None -> None in
- let rec expression_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map expression l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map expression l)
- | Ast.STARS(l) -> Ast.STARS(List.map expression l)) in
- expdotsfn all_functions k d
-
- and parameter_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map parameterTypeDef l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map parameterTypeDef l)
- | Ast.STARS(l) -> Ast.STARS(List.map parameterTypeDef l)) in
- paramdotsfn all_functions k d
-
- and statement_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map statement l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map statement l)
- | Ast.STARS(l) -> Ast.STARS(List.map statement l)) in
- stmtdotsfn all_functions k d
-
- and declaration_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map declaration l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map declaration l)
- | Ast.STARS(l) -> Ast.STARS(List.map declaration l)) in
- decldotsfn all_functions k d
-
- and ident i =
- let k i =
- Ast.rewrap i
- (match Ast.unwrap i with
- Ast.Id(name) -> Ast.Id(string_mcode name)
- | Ast.MetaId(name,constraints,keep,inherited) ->
- Ast.MetaId(meta_mcode name,constraints,keep,inherited)
- | Ast.MetaFunc(name,constraints,keep,inherited) ->
- Ast.MetaFunc(meta_mcode name,constraints,keep,inherited)
- | Ast.MetaLocalFunc(name,constraints,keep,inherited) ->
- Ast.MetaLocalFunc(meta_mcode name,constraints,keep,inherited)
- | Ast.OptIdent(id) -> Ast.OptIdent(ident id)
- | Ast.UniqueIdent(id) -> Ast.UniqueIdent(ident id)) in
- identfn all_functions k i
-
- and expression e =
- let k e =
- Ast.rewrap e
- (match Ast.unwrap e with
- Ast.Ident(id) -> Ast.Ident(ident id)
- | Ast.Constant(const) -> Ast.Constant(const_mcode const)
- | Ast.FunCall(fn,lp,args,rp) ->
- Ast.FunCall(expression fn, string_mcode lp, expression_dots args,
- string_mcode rp)
- | Ast.Assignment(left,op,right,simple) ->
- Ast.Assignment(expression left, assign_mcode op, expression right,
- simple)
- | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
- Ast.CondExpr(expression exp1, string_mcode why,
- get_option expression exp2, string_mcode colon,
- expression exp3)
- | Ast.Postfix(exp,op) -> Ast.Postfix(expression exp,fix_mcode op)
- | Ast.Infix(exp,op) -> Ast.Infix(expression exp,fix_mcode op)
- | Ast.Unary(exp,op) -> Ast.Unary(expression exp,unary_mcode op)
- | Ast.Binary(left,op,right) ->
- Ast.Binary(expression left, binary_mcode op, expression right)
- | Ast.Nested(left,op,right) ->
- Ast.Nested(expression left, binary_mcode op, expression right)
- | Ast.Paren(lp,exp,rp) ->
- Ast.Paren(string_mcode lp, expression exp, string_mcode rp)
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- Ast.ArrayAccess(expression exp1, string_mcode lb, expression exp2,
- string_mcode rb)
- | Ast.RecordAccess(exp,pt,field) ->
- Ast.RecordAccess(expression exp, string_mcode pt, ident field)
- | Ast.RecordPtAccess(exp,ar,field) ->
- Ast.RecordPtAccess(expression exp, string_mcode ar, ident field)
- | Ast.Cast(lp,ty,rp,exp) ->
- Ast.Cast(string_mcode lp, fullType ty, string_mcode rp,
- expression exp)
- | Ast.SizeOfExpr(szf,exp) ->
- Ast.SizeOfExpr(string_mcode szf, expression exp)
- | Ast.SizeOfType(szf,lp,ty,rp) ->
- Ast.SizeOfType(string_mcode szf,string_mcode lp, fullType ty,
- string_mcode rp)
- | Ast.TypeExp(ty) -> Ast.TypeExp(fullType ty)
- | Ast.MetaErr(name,constraints,keep,inherited) ->
- Ast.MetaErr(meta_mcode name,constraints,keep,inherited)
- | Ast.MetaExpr(name,constraints,keep,ty,form,inherited) ->
- Ast.MetaExpr(meta_mcode name,constraints,keep,ty,form,inherited)
- | Ast.MetaExprList(name,lenname_inh,keep,inherited) ->
- Ast.MetaExprList(meta_mcode name,lenname_inh,keep,inherited)
- | Ast.EComma(cm) -> Ast.EComma(string_mcode cm)
- | Ast.DisjExpr(exp_list) -> Ast.DisjExpr(List.map expression exp_list)
- | Ast.NestExpr(expr_dots,whencode,multi) ->
- Ast.NestExpr(expression_dots expr_dots,
- get_option expression whencode,multi)
- | Ast.Edots(dots,whencode) ->
- Ast.Edots(string_mcode dots,get_option expression whencode)
- | Ast.Ecircles(dots,whencode) ->
- Ast.Ecircles(string_mcode dots,get_option expression whencode)
- | Ast.Estars(dots,whencode) ->
- Ast.Estars(string_mcode dots,get_option expression whencode)
- | Ast.OptExp(exp) -> Ast.OptExp(expression exp)
- | Ast.UniqueExp(exp) -> Ast.UniqueExp(expression exp)) in
- exprfn all_functions k e
-
- and fullType ft =
- let k ft =
- Ast.rewrap ft
- (match Ast.unwrap ft with
- Ast.Type(cv,ty) -> Ast.Type (get_option cv_mcode cv, typeC ty)
- | Ast.DisjType(types) -> Ast.DisjType(List.map fullType types)
- | Ast.OptType(ty) -> Ast.OptType(fullType ty)
- | Ast.UniqueType(ty) -> Ast.UniqueType(fullType ty)) in
- ftfn all_functions k ft
-
- and typeC ty =
- let k ty =
- Ast.rewrap ty
- (match Ast.unwrap ty with
- Ast.BaseType(ty,strings) ->
- Ast.BaseType (ty, List.map string_mcode strings)
- | Ast.SignedT(sgn,ty) ->
- Ast.SignedT(sign_mcode sgn,get_option typeC ty)
- | Ast.Pointer(ty,star) ->
- Ast.Pointer (fullType ty, string_mcode star)
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- Ast.FunctionPointer(fullType ty,string_mcode lp1,string_mcode star,
- string_mcode rp1,string_mcode lp2,
- parameter_dots params,
- string_mcode rp2)
- | Ast.FunctionType(allminus,ty,lp,params,rp) ->
- Ast.FunctionType(allminus,get_option fullType ty,string_mcode lp,
- parameter_dots params,string_mcode rp)
- | Ast.Array(ty,lb,size,rb) ->
- Ast.Array(fullType ty, string_mcode lb,
- get_option expression size, string_mcode rb)
- | Ast.EnumName(kind,name) ->
- Ast.EnumName(string_mcode kind, ident name)
- | Ast.StructUnionName(kind,name) ->
- Ast.StructUnionName (struct_mcode kind, get_option ident name)
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- Ast.StructUnionDef (fullType ty,
- string_mcode lb, declaration_dots decls,
- string_mcode rb)
- | Ast.TypeName(name) -> Ast.TypeName(string_mcode name)
- | Ast.MetaType(name,keep,inherited) ->
- Ast.MetaType(meta_mcode name,keep,inherited)) in
- tyfn all_functions k ty
-
- and declaration d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- Ast.Init(get_option storage_mcode stg, fullType ty, ident id,
- string_mcode eq, initialiser ini, string_mcode sem)
- | Ast.UnInit(stg,ty,id,sem) ->
- Ast.UnInit(get_option storage_mcode stg, fullType ty, ident id,
- string_mcode sem)
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- Ast.MacroDecl(ident name, string_mcode lp, expression_dots args,
- string_mcode rp,string_mcode sem)
- | Ast.TyDecl(ty,sem) -> Ast.TyDecl(fullType ty, string_mcode sem)
- | Ast.Typedef(stg,ty,id,sem) ->
- Ast.Typedef(string_mcode stg, fullType ty, typeC id,
- string_mcode sem)
- | Ast.DisjDecl(decls) -> Ast.DisjDecl(List.map declaration decls)
- | Ast.Ddots(dots,whencode) ->
- Ast.Ddots(string_mcode dots, get_option declaration whencode)
- | Ast.MetaDecl(name,keep,inherited) ->
- Ast.MetaDecl(meta_mcode name,keep,inherited)
- | Ast.OptDecl(decl) -> Ast.OptDecl(declaration decl)
- | Ast.UniqueDecl(decl) -> Ast.UniqueDecl(declaration decl)) in
- declfn all_functions k d
-
- and initialiser i =
- let k i =
- Ast.rewrap i
- (match Ast.unwrap i with
- Ast.InitExpr(exp) -> Ast.InitExpr(expression exp)
- | Ast.InitList(lb,initlist,rb,whencode) ->
- Ast.InitList(string_mcode lb, List.map initialiser initlist,
- string_mcode rb, List.map initialiser whencode)
- | Ast.InitGccDotName(dot,name,eq,ini) ->
- Ast.InitGccDotName
- (string_mcode dot, ident name, string_mcode eq, initialiser ini)
- | Ast.InitGccName(name,eq,ini) ->
- Ast.InitGccName(ident name, string_mcode eq, initialiser ini)
- | Ast.InitGccIndex(lb,exp,rb,eq,ini) ->
- Ast.InitGccIndex
- (string_mcode lb, expression exp, string_mcode rb,
- string_mcode eq, initialiser ini)
- | Ast.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- Ast.InitGccRange
- (string_mcode lb, expression exp1, string_mcode dots,
- expression exp2, string_mcode rb, string_mcode eq,
- initialiser ini)
- | Ast.IComma(cm) -> Ast.IComma(string_mcode cm)
- | Ast.OptIni(i) -> Ast.OptIni(initialiser i)
- | Ast.UniqueIni(i) -> Ast.UniqueIni(initialiser i)) in
- initfn all_functions k i
-
- and parameterTypeDef p =
- let k p =
- Ast.rewrap p
- (match Ast.unwrap p with
- Ast.VoidParam(ty) -> Ast.VoidParam(fullType ty)
- | Ast.Param(ty,id) -> Ast.Param(fullType ty, get_option ident id)
- | Ast.MetaParam(name,keep,inherited) ->
- Ast.MetaParam(meta_mcode name,keep,inherited)
- | Ast.MetaParamList(name,lenname_inh,keep,inherited) ->
- Ast.MetaParamList(meta_mcode name,lenname_inh,keep,inherited)
- | Ast.PComma(cm) -> Ast.PComma(string_mcode cm)
- | Ast.Pdots(dots) -> Ast.Pdots(string_mcode dots)
- | Ast.Pcircles(dots) -> Ast.Pcircles(string_mcode dots)
- | Ast.OptParam(param) -> Ast.OptParam(parameterTypeDef param)
- | Ast.UniqueParam(param) -> Ast.UniqueParam(parameterTypeDef param)) in
- paramfn all_functions k p
-
- and rule_elem re =
- let k re =
- Ast.rewrap re
- (match Ast.unwrap re with
- Ast.FunHeader(bef,allminus,fi,name,lp,params,rp) ->
- Ast.FunHeader(bef,allminus,List.map fninfo fi,ident name,
- string_mcode lp, parameter_dots params,
- string_mcode rp)
- | Ast.Decl(bef,allminus,decl) ->
- Ast.Decl(bef,allminus,declaration decl)
- | Ast.SeqStart(brace) -> Ast.SeqStart(string_mcode brace)
- | Ast.SeqEnd(brace) -> Ast.SeqEnd(string_mcode brace)
- | Ast.ExprStatement(exp,sem) ->
- Ast.ExprStatement (expression exp, string_mcode sem)
- | Ast.IfHeader(iff,lp,exp,rp) ->
- Ast.IfHeader(string_mcode iff, string_mcode lp, expression exp,
- string_mcode rp)
- | Ast.Else(els) -> Ast.Else(string_mcode els)
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- Ast.WhileHeader(string_mcode whl, string_mcode lp, expression exp,
- string_mcode rp)
- | Ast.DoHeader(d) -> Ast.DoHeader(string_mcode d)
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- Ast.WhileTail(string_mcode whl, string_mcode lp, expression exp,
- string_mcode rp, string_mcode sem)
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- Ast.ForHeader(string_mcode fr, string_mcode lp,
- get_option expression e1, string_mcode sem1,
- get_option expression e2, string_mcode sem2,
- get_option expression e3, string_mcode rp)
- | Ast.IteratorHeader(whl,lp,args,rp) ->
- Ast.IteratorHeader(ident whl, string_mcode lp,
- expression_dots args, string_mcode rp)
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- Ast.SwitchHeader(string_mcode switch, string_mcode lp,
- expression exp, string_mcode rp)
- | Ast.Break(br,sem) ->
- Ast.Break(string_mcode br, string_mcode sem)
- | Ast.Continue(cont,sem) ->
- Ast.Continue(string_mcode cont, string_mcode sem)
- | Ast.Label(l,dd) -> Ast.Label(ident l, string_mcode dd)
- | Ast.Goto(goto,l,sem) ->
- Ast.Goto(string_mcode goto,ident l,string_mcode sem)
- | Ast.Return(ret,sem) ->
- Ast.Return(string_mcode ret, string_mcode sem)
- | Ast.ReturnExpr(ret,exp,sem) ->
- Ast.ReturnExpr(string_mcode ret, expression exp, string_mcode sem)
- | Ast.MetaStmt(name,keep,seqible,inherited) ->
- Ast.MetaStmt(meta_mcode name,keep,seqible,inherited)
- | Ast.MetaStmtList(name,keep,inherited) ->
- Ast.MetaStmtList(meta_mcode name,keep,inherited)
- | Ast.MetaRuleElem(name,keep,inherited) ->
- Ast.MetaRuleElem(meta_mcode name,keep,inherited)
- | Ast.Exp(exp) -> Ast.Exp(expression exp)
- | Ast.TopExp(exp) -> Ast.TopExp(expression exp)
- | Ast.Ty(ty) -> Ast.Ty(fullType ty)
- | Ast.TopInit(init) -> Ast.TopInit(initialiser init)
- | Ast.Include(inc,name) ->
- Ast.Include(string_mcode inc,inc_file_mcode name)
- | Ast.DefineHeader(def,id,params) ->
- Ast.DefineHeader(string_mcode def,ident id,
- define_parameters params)
- | Ast.Default(def,colon) ->
- Ast.Default(string_mcode def,string_mcode colon)
- | Ast.Case(case,exp,colon) ->
- Ast.Case(string_mcode case,expression exp,string_mcode colon)
- | Ast.DisjRuleElem(res) -> Ast.DisjRuleElem(List.map rule_elem res)) in
- rulefn all_functions k re
-
- (* not parameterizable for now... *)
- and define_parameters p =
- let k p =
- Ast.rewrap p
- (match Ast.unwrap p with
- Ast.NoParams -> Ast.NoParams
- | Ast.DParams(lp,params,rp) ->
- Ast.DParams(string_mcode lp,define_param_dots params,
- string_mcode rp)) in
- k p
-
- and define_param_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map define_param l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map define_param l)
- | Ast.STARS(l) -> Ast.STARS(List.map define_param l)) in
- k d
-
- and define_param p =
- let k p =
- Ast.rewrap p
- (match Ast.unwrap p with
- Ast.DParam(id) -> Ast.DParam(ident id)
- | Ast.DPComma(comma) -> Ast.DPComma(string_mcode comma)
- | Ast.DPdots(d) -> Ast.DPdots(string_mcode d)
- | Ast.DPcircles(c) -> Ast.DPcircles(string_mcode c)
- | Ast.OptDParam(dp) -> Ast.OptDParam(define_param dp)
- | Ast.UniqueDParam(dp) -> Ast.UniqueDParam(define_param dp)) in
- k p
-
- and process_bef_aft s =
- Ast.set_dots_bef_aft
- (match Ast.get_dots_bef_aft s with
- Ast.NoDots -> Ast.NoDots
- | Ast.DroppingBetweenDots(stm,ind) ->
- Ast.DroppingBetweenDots(statement stm,ind)
- | Ast.AddingBetweenDots(stm,ind) ->
- Ast.AddingBetweenDots(statement stm,ind))
- s
-
- and statement s =
- let k s =
- Ast.rewrap s
- (match Ast.unwrap s with
- Ast.Seq(lbrace,decls,body,rbrace) ->
- Ast.Seq(rule_elem lbrace, statement_dots decls,
- statement_dots body, rule_elem rbrace)
- | Ast.IfThen(header,branch,aft) ->
- Ast.IfThen(rule_elem header, statement branch,aft)
- | Ast.IfThenElse(header,branch1,els,branch2,aft) ->
- Ast.IfThenElse(rule_elem header, statement branch1, rule_elem els,
- statement branch2, aft)
- | Ast.While(header,body,aft) ->
- Ast.While(rule_elem header, statement body, aft)
- | Ast.Do(header,body,tail) ->
- Ast.Do(rule_elem header, statement body, rule_elem tail)
- | Ast.For(header,body,aft) ->
- Ast.For(rule_elem header, statement body, aft)
- | Ast.Iterator(header,body,aft) ->
- Ast.Iterator(rule_elem header, statement body, aft)
- | Ast.Switch(header,lb,cases,rb) ->
- Ast.Switch(rule_elem header,rule_elem lb,
- List.map case_line cases,rule_elem rb)
- | Ast.Atomic(re) -> Ast.Atomic(rule_elem re)
- | Ast.Disj(stmt_dots_list) ->
- Ast.Disj (List.map statement_dots stmt_dots_list)
- | Ast.Nest(stmt_dots,whn,multi,bef,aft) ->
- Ast.Nest(statement_dots stmt_dots,
- List.map (whencode statement_dots statement) whn,
- multi,bef,aft)
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- Ast.FunDecl(rule_elem header,rule_elem lbrace,
- statement_dots decls,
- statement_dots body, rule_elem rbrace)
- | Ast.Define(header,body) ->
- Ast.Define(rule_elem header,statement_dots body)
- | Ast.Dots(d,whn,bef,aft) ->
- Ast.Dots(string_mcode d,
- List.map (whencode statement_dots statement) whn,bef,aft)
- | Ast.Circles(d,whn,bef,aft) ->
- Ast.Circles(string_mcode d,
- List.map (whencode statement_dots statement) whn,
- bef,aft)
- | Ast.Stars(d,whn,bef,aft) ->
- Ast.Stars(string_mcode d,
- List.map (whencode statement_dots statement) whn,bef,aft)
- | Ast.OptStm(stmt) -> Ast.OptStm(statement stmt)
- | Ast.UniqueStm(stmt) -> Ast.UniqueStm(statement stmt)) in
- let s = stmtfn all_functions k s in
- (* better to do this after, in case there is an equality test on the whole
- statement, eg in free_vars. equality test would require that this
- subterm not already be changed *)
- process_bef_aft s
-
- and fninfo = function
- Ast.FStorage(stg) -> Ast.FStorage(storage_mcode stg)
- | Ast.FType(ty) -> Ast.FType(fullType ty)
- | Ast.FInline(inline) -> Ast.FInline(string_mcode inline)
- | Ast.FAttr(attr) -> Ast.FAttr(string_mcode attr)
-
- and whencode notfn alwaysfn = function
- Ast.WhenNot a -> Ast.WhenNot (notfn a)
- | Ast.WhenAlways a -> Ast.WhenAlways (alwaysfn a)
- | Ast.WhenModifier(x) -> Ast.WhenModifier(x)
- | Ast.WhenNotTrue(e) -> Ast.WhenNotTrue(rule_elem e)
- | Ast.WhenNotFalse(e) -> Ast.WhenNotFalse(rule_elem e)
-
- and case_line c =
- let k c =
- Ast.rewrap c
- (match Ast.unwrap c with
- Ast.CaseLine(header,code) ->
- Ast.CaseLine(rule_elem header,statement_dots code)
- | Ast.OptCase(case) -> Ast.OptCase(case_line case)) in
- casefn all_functions k c
-
- and top_level t =
- let k t =
- Ast.rewrap t
- (match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) ->
- Ast.FILEINFO (string_mcode old_file, string_mcode new_file)
- | Ast.DECL(stmt) -> Ast.DECL(statement stmt)
- | Ast.CODE(stmt_dots) -> Ast.CODE(statement_dots stmt_dots)
- | Ast.ERRORWORDS(exps) -> Ast.ERRORWORDS (List.map expression exps)) in
- topfn all_functions k t
-
- and anything a =
- let k = function
- (*in many cases below, the thing is not even mcode, so we do nothing*)
- Ast.FullTypeTag(ft) -> Ast.FullTypeTag(fullType ft)
- | Ast.BaseTypeTag(bt) as x -> x
- | Ast.StructUnionTag(su) as x -> x
- | Ast.SignTag(sgn) as x -> x
- | Ast.IdentTag(id) -> Ast.IdentTag(ident id)
- | Ast.ExpressionTag(exp) -> Ast.ExpressionTag(expression exp)
- | Ast.ConstantTag(cst) as x -> x
- | Ast.UnaryOpTag(unop) as x -> x
- | Ast.AssignOpTag(asgnop) as x -> x
- | Ast.FixOpTag(fixop) as x -> x
- | Ast.BinaryOpTag(binop) as x -> x
- | Ast.ArithOpTag(arithop) as x -> x
- | Ast.LogicalOpTag(logop) as x -> x
- | Ast.InitTag(decl) -> Ast.InitTag(initialiser decl)
- | Ast.DeclarationTag(decl) -> Ast.DeclarationTag(declaration decl)
- | Ast.StorageTag(stg) as x -> x
- | Ast.IncFileTag(stg) as x -> x
- | Ast.Rule_elemTag(rule) -> Ast.Rule_elemTag(rule_elem rule)
- | Ast.StatementTag(rule) -> Ast.StatementTag(statement rule)
- | Ast.CaseLineTag(case) -> Ast.CaseLineTag(case_line case)
- | Ast.ConstVolTag(cv) as x -> x
- | Ast.Token(tok,info) as x -> x
- | Ast.Code(cd) -> Ast.Code(top_level cd)
- | Ast.ExprDotsTag(ed) -> Ast.ExprDotsTag(expression_dots ed)
- | Ast.ParamDotsTag(pd) -> Ast.ParamDotsTag(parameter_dots pd)
- | Ast.StmtDotsTag(sd) -> Ast.StmtDotsTag(statement_dots sd)
- | Ast.DeclDotsTag(sd) -> Ast.DeclDotsTag(declaration_dots sd)
- | Ast.TypeCTag(ty) -> Ast.TypeCTag(typeC ty)
- | Ast.ParamTag(param) -> Ast.ParamTag(parameterTypeDef param)
- | Ast.SgrepStartTag(tok) as x -> x
- | Ast.SgrepEndTag(tok) as x -> x in
- anyfn all_functions k a
-
- and all_functions =
- {rebuilder_ident = ident;
- rebuilder_expression = expression;
- rebuilder_fullType= fullType;
- rebuilder_typeC = typeC;
- rebuilder_declaration = declaration;
- rebuilder_initialiser = initialiser;
- rebuilder_parameter = parameterTypeDef;
- rebuilder_parameter_list = parameter_dots;
- rebuilder_rule_elem = rule_elem;
- rebuilder_statement = statement;
- rebuilder_case_line = case_line;
- rebuilder_top_level = top_level;
- rebuilder_expression_dots = expression_dots;
- rebuilder_statement_dots = statement_dots;
- rebuilder_declaration_dots = declaration_dots;
- rebuilder_define_param_dots = define_param_dots;
- rebuilder_define_param = define_param;
- rebuilder_define_parameters = define_parameters;
- rebuilder_anything = anything} in
- all_functions
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast = Ast_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Generic traversal: combiner *)
-(* parameters:
- combining function
- treatment of: mcode, identifiers, expressions, fullTypes, types,
- declarations, statements, toplevels
- default value for options *)
-
-type 'a combiner =
- {combiner_ident : Ast.ident -> 'a;
- combiner_expression : Ast.expression -> 'a;
- combiner_fullType : Ast.fullType -> 'a;
- combiner_typeC : Ast.typeC -> 'a;
- combiner_declaration : Ast.declaration -> 'a;
- combiner_initialiser : Ast.initialiser -> 'a;
- combiner_parameter : Ast.parameterTypeDef -> 'a;
- combiner_parameter_list : Ast.parameter_list -> 'a;
- combiner_rule_elem : Ast.rule_elem -> 'a;
- combiner_statement : Ast.statement -> 'a;
- combiner_case_line : Ast.case_line -> 'a;
- combiner_top_level : Ast.top_level -> 'a;
- combiner_anything : Ast.anything -> 'a;
- combiner_expression_dots : Ast.expression Ast.dots -> 'a;
- combiner_statement_dots : Ast.statement Ast.dots -> 'a;
- combiner_declaration_dots : Ast.declaration Ast.dots -> 'a}
-
-type ('mc,'a) cmcode = 'a combiner -> 'mc Ast_cocci.mcode -> 'a
-type ('cd,'a) ccode = 'a combiner -> ('cd -> 'a) -> 'cd -> 'a
-
-
-let combiner bind option_default
- meta_mcodefn string_mcodefn const_mcodefn assign_mcodefn fix_mcodefn
- unary_mcodefn binary_mcodefn
- cv_mcodefn sign_mcodefn struct_mcodefn storage_mcodefn
- inc_file_mcodefn
- expdotsfn paramdotsfn stmtdotsfn decldotsfn
- identfn exprfn ftfn tyfn initfn paramfn declfn rulefn stmtfn casefn
- topfn anyfn =
- let multibind l =
- let rec loop = function
- [] -> option_default
- | [x] -> x
- | x::xs -> bind x (loop xs) in
- loop l in
- let get_option f = function
- Some x -> f x
- | None -> option_default in
-
- let rec meta_mcode x = meta_mcodefn all_functions x
- and string_mcode x = string_mcodefn all_functions x
- and const_mcode x = const_mcodefn all_functions x
- and assign_mcode x = assign_mcodefn all_functions x
- and fix_mcode x = fix_mcodefn all_functions x
- and unary_mcode x = unary_mcodefn all_functions x
- and binary_mcode x = binary_mcodefn all_functions x
- and cv_mcode x = cv_mcodefn all_functions x
- and sign_mcode x = sign_mcodefn all_functions x
- and struct_mcode x = struct_mcodefn all_functions x
- and storage_mcode x = storage_mcodefn all_functions x
- and inc_file_mcode x = inc_file_mcodefn all_functions x
-
- and expression_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map expression l) in
- expdotsfn all_functions k d
-
- and parameter_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map parameterTypeDef l) in
- paramdotsfn all_functions k d
-
- and statement_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map statement l) in
- stmtdotsfn all_functions k d
-
- and declaration_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map declaration l) in
- decldotsfn all_functions k d
-
- and ident i =
- let k i =
- match Ast.unwrap i with
- Ast.Id(name) -> string_mcode name
- | Ast.MetaId(name,_,_,_) -> meta_mcode name
- | Ast.MetaFunc(name,_,_,_) -> meta_mcode name
- | Ast.MetaLocalFunc(name,_,_,_) -> meta_mcode name
- | Ast.OptIdent(id) -> ident id
- | Ast.UniqueIdent(id) -> ident id in
- identfn all_functions k i
-
- and expression e =
- let k e =
- match Ast.unwrap e with
- Ast.Ident(id) -> ident id
- | Ast.Constant(const) -> const_mcode const
- | Ast.FunCall(fn,lp,args,rp) ->
- multibind [expression fn; string_mcode lp; expression_dots args;
- string_mcode rp]
- | Ast.Assignment(left,op,right,simple) ->
- multibind [expression left; assign_mcode op; expression right]
- | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
- multibind [expression exp1; string_mcode why;
- get_option expression exp2; string_mcode colon;
- expression exp3]
- | Ast.Postfix(exp,op) -> bind (expression exp) (fix_mcode op)
- | Ast.Infix(exp,op) -> bind (fix_mcode op) (expression exp)
- | Ast.Unary(exp,op) -> bind (unary_mcode op) (expression exp)
- | Ast.Binary(left,op,right) ->
- multibind [expression left; binary_mcode op; expression right]
- | Ast.Nested(left,op,right) ->
- multibind [expression left; binary_mcode op; expression right]
- | Ast.Paren(lp,exp,rp) ->
- multibind [string_mcode lp; expression exp; string_mcode rp]
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- multibind
- [expression exp1; string_mcode lb; expression exp2;
- string_mcode rb]
- | Ast.RecordAccess(exp,pt,field) ->
- multibind [expression exp; string_mcode pt; ident field]
- | Ast.RecordPtAccess(exp,ar,field) ->
- multibind [expression exp; string_mcode ar; ident field]
- | Ast.Cast(lp,ty,rp,exp) ->
- multibind
- [string_mcode lp; fullType ty; string_mcode rp; expression exp]
- | Ast.SizeOfExpr(szf,exp) ->
- multibind [string_mcode szf; expression exp]
- | Ast.SizeOfType(szf,lp,ty,rp) ->
- multibind
- [string_mcode szf; string_mcode lp; fullType ty; string_mcode rp]
- | Ast.TypeExp(ty) -> fullType ty
- | Ast.MetaErr(name,_,_,_)
- | Ast.MetaExpr(name,_,_,_,_,_)
- | Ast.MetaExprList(name,_,_,_) -> meta_mcode name
- | Ast.EComma(cm) -> string_mcode cm
- | Ast.DisjExpr(exp_list) -> multibind (List.map expression exp_list)
- | Ast.NestExpr(expr_dots,whencode,multi) ->
- bind (expression_dots expr_dots) (get_option expression whencode)
- | Ast.Edots(dots,whencode) | Ast.Ecircles(dots,whencode)
- | Ast.Estars(dots,whencode) ->
- bind (string_mcode dots) (get_option expression whencode)
- | Ast.OptExp(exp) | Ast.UniqueExp(exp) ->
- expression exp in
- exprfn all_functions k e
-
- and fullType ft =
- let k ft =
- match Ast.unwrap ft with
- Ast.Type(cv,ty) -> bind (get_option cv_mcode cv) (typeC ty)
- | Ast.DisjType(types) -> multibind (List.map fullType types)
- | Ast.OptType(ty) -> fullType ty
- | Ast.UniqueType(ty) -> fullType ty in
- ftfn all_functions k ft
-
- and function_pointer (ty,lp1,star,rp1,lp2,params,rp2) extra =
- (* have to put the treatment of the identifier into the right position *)
- multibind
- ([fullType ty; string_mcode lp1; string_mcode star] @ extra @
- [string_mcode rp1;
- string_mcode lp2; parameter_dots params; string_mcode rp2])
-
- and function_type (ty,lp1,params,rp1) extra =
- (* have to put the treatment of the identifier into the right position *)
- multibind
- ([get_option fullType ty] @ extra @
- [string_mcode lp1; parameter_dots params; string_mcode rp1])
-
- and array_type (ty,lb,size,rb) extra =
- multibind
- ([fullType ty] @ extra @
- [string_mcode lb; get_option expression size; string_mcode rb])
-
- and typeC ty =
- let k ty =
- match Ast.unwrap ty with
- Ast.BaseType(ty,strings) -> multibind (List.map string_mcode strings)
- | Ast.SignedT(sgn,ty) -> bind (sign_mcode sgn) (get_option typeC ty)
- | Ast.Pointer(ty,star) ->
- bind (fullType ty) (string_mcode star)
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- function_pointer (ty,lp1,star,rp1,lp2,params,rp2) []
- | Ast.FunctionType (_,ty,lp1,params,rp1) ->
- function_type (ty,lp1,params,rp1) []
- | Ast.Array(ty,lb,size,rb) -> array_type (ty,lb,size,rb) []
- | Ast.EnumName(kind,name) -> bind (string_mcode kind) (ident name)
- | Ast.StructUnionName(kind,name) ->
- bind (struct_mcode kind) (get_option ident name)
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- multibind
- [fullType ty; string_mcode lb; declaration_dots decls;
- string_mcode rb]
- | Ast.TypeName(name) -> string_mcode name
- | Ast.MetaType(name,_,_) -> meta_mcode name in
- tyfn all_functions k ty
-
- and named_type ty id =
- match Ast.unwrap ty with
- Ast.Type(None,ty1) ->
- (match Ast.unwrap ty1 with
- Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- function_pointer (ty,lp1,star,rp1,lp2,params,rp2) [ident id]
- | Ast.FunctionType(_,ty,lp1,params,rp1) ->
- function_type (ty,lp1,params,rp1) [ident id]
- | Ast.Array(ty,lb,size,rb) -> array_type (ty,lb,size,rb) [ident id]
- | _ -> bind (fullType ty) (ident id))
- | _ -> bind (fullType ty) (ident id)
-
- and declaration d =
- let k d =
- match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- bind (get_option storage_mcode stg)
- (bind (named_type ty id)
- (multibind
- [string_mcode eq; initialiser ini; string_mcode sem]))
- | Ast.UnInit(stg,ty,id,sem) ->
- bind (get_option storage_mcode stg)
- (bind (named_type ty id) (string_mcode sem))
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- multibind
- [ident name; string_mcode lp; expression_dots args;
- string_mcode rp; string_mcode sem]
- | Ast.TyDecl(ty,sem) -> bind (fullType ty) (string_mcode sem)
- | Ast.Typedef(stg,ty,id,sem) ->
- bind (string_mcode stg)
- (bind (fullType ty) (bind (typeC id) (string_mcode sem)))
- | Ast.DisjDecl(decls) -> multibind (List.map declaration decls)
- | Ast.Ddots(dots,whencode) ->
- bind (string_mcode dots) (get_option declaration whencode)
- | Ast.MetaDecl(name,_,_) -> meta_mcode name
- | Ast.OptDecl(decl) -> declaration decl
- | Ast.UniqueDecl(decl) -> declaration decl in
- declfn all_functions k d
-
- and initialiser i =
- let k i =
- match Ast.unwrap i with
- Ast.MetaInit(name,_,_) -> meta_mcode name
- | Ast.InitExpr(exp) -> expression exp
- | Ast.InitList(lb,initlist,rb,whencode) ->
- multibind
- [string_mcode lb;
- multibind (List.map initialiser initlist);
- string_mcode rb;
- multibind (List.map initialiser whencode)]
- | Ast.InitGccName(name,eq,ini) ->
- multibind [ident name; string_mcode eq; initialiser ini]
- | Ast.InitGccExt(designators,eq,ini) ->
- multibind
- ((List.map designator designators) @
- [string_mcode eq; initialiser ini])
- | Ast.IComma(cm) -> string_mcode cm
- | Ast.OptIni(i) -> initialiser i
- | Ast.UniqueIni(i) -> initialiser i in
- initfn all_functions k i
-
- and designator = function
- Ast.DesignatorField(dot,id) -> bind (string_mcode dot) (ident id)
- | Ast.DesignatorIndex(lb,exp,rb) ->
- bind (string_mcode lb) (bind (expression exp) (string_mcode rb))
- | Ast.DesignatorRange(lb,min,dots,max,rb) ->
- multibind
- [string_mcode lb; expression min; string_mcode dots;
- expression max; string_mcode rb]
-
- and parameterTypeDef p =
- let k p =
- match Ast.unwrap p with
- Ast.VoidParam(ty) -> fullType ty
- | Ast.Param(ty,Some id) -> named_type ty id
- | Ast.Param(ty,None) -> fullType ty
- | Ast.MetaParam(name,_,_) -> meta_mcode name
- | Ast.MetaParamList(name,_,_,_) -> meta_mcode name
- | Ast.PComma(cm) -> string_mcode cm
- | Ast.Pdots(dots) -> string_mcode dots
- | Ast.Pcircles(dots) -> string_mcode dots
- | Ast.OptParam(param) -> parameterTypeDef param
- | Ast.UniqueParam(param) -> parameterTypeDef param in
- paramfn all_functions k p
-
- and rule_elem re =
- let k re =
- match Ast.unwrap re with
- Ast.FunHeader(_,_,fi,name,lp,params,rp) ->
- multibind
- ((List.map fninfo fi) @
- [ident name;string_mcode lp;parameter_dots params;
- string_mcode rp])
- | Ast.Decl(_,_,decl) -> declaration decl
- | Ast.SeqStart(brace) -> string_mcode brace
- | Ast.SeqEnd(brace) -> string_mcode brace
- | Ast.ExprStatement(exp,sem) ->
- bind (expression exp) (string_mcode sem)
- | Ast.IfHeader(iff,lp,exp,rp) ->
- multibind [string_mcode iff; string_mcode lp; expression exp;
- string_mcode rp]
- | Ast.Else(els) -> string_mcode els
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- multibind [string_mcode whl; string_mcode lp; expression exp;
- string_mcode rp]
- | Ast.DoHeader(d) -> string_mcode d
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- multibind [string_mcode whl; string_mcode lp; expression exp;
- string_mcode rp; string_mcode sem]
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- multibind [string_mcode fr; string_mcode lp;
- get_option expression e1; string_mcode sem1;
- get_option expression e2; string_mcode sem2;
- get_option expression e3; string_mcode rp]
- | Ast.IteratorHeader(nm,lp,args,rp) ->
- multibind [ident nm; string_mcode lp;
- expression_dots args; string_mcode rp]
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- multibind [string_mcode switch; string_mcode lp; expression exp;
- string_mcode rp]
- | Ast.Break(br,sem) -> bind (string_mcode br) (string_mcode sem)
- | Ast.Continue(cont,sem) -> bind (string_mcode cont) (string_mcode sem)
- | Ast.Label(l,dd) -> bind (ident l) (string_mcode dd)
- | Ast.Goto(goto,l,sem) ->
- bind (string_mcode goto) (bind (ident l) (string_mcode sem))
- | Ast.Return(ret,sem) -> bind (string_mcode ret) (string_mcode sem)
- | Ast.ReturnExpr(ret,exp,sem) ->
- multibind [string_mcode ret; expression exp; string_mcode sem]
- | Ast.MetaStmt(name,_,_,_) -> meta_mcode name
- | Ast.MetaStmtList(name,_,_) -> meta_mcode name
- | Ast.MetaRuleElem(name,_,_) -> meta_mcode name
- | Ast.Exp(exp) -> expression exp
- | Ast.TopExp(exp) -> expression exp
- | Ast.Ty(ty) -> fullType ty
- | Ast.TopInit(init) -> initialiser init
- | Ast.Include(inc,name) -> bind (string_mcode inc) (inc_file_mcode name)
- | Ast.DefineHeader(def,id,params) ->
- multibind [string_mcode def; ident id; define_parameters params]
- | Ast.Default(def,colon) -> bind (string_mcode def) (string_mcode colon)
- | Ast.Case(case,exp,colon) ->
- multibind [string_mcode case; expression exp; string_mcode colon]
- | Ast.DisjRuleElem(res) -> multibind (List.map rule_elem res) in
- rulefn all_functions k re
-
- (* not parameterizable for now... *)
- and define_parameters p =
- let k p =
- match Ast.unwrap p with
- Ast.NoParams -> option_default
- | Ast.DParams(lp,params,rp) ->
- multibind
- [string_mcode lp; define_param_dots params; string_mcode rp] in
- k p
-
- and define_param_dots d =
- let k d =
- match Ast.unwrap d with
- Ast.DOTS(l) | Ast.CIRCLES(l) | Ast.STARS(l) ->
- multibind (List.map define_param l) in
- k d
-
- and define_param p =
- let k p =
- match Ast.unwrap p with
- Ast.DParam(id) -> ident id
- | Ast.DPComma(comma) -> string_mcode comma
- | Ast.DPdots(d) -> string_mcode d
- | Ast.DPcircles(c) -> string_mcode c
- | Ast.OptDParam(dp) -> define_param dp
- | Ast.UniqueDParam(dp) -> define_param dp in
- k p
-
- (* discard the result, because the statement is assumed to be already
- represented elsewhere in the code *)
- and process_bef_aft s =
- match Ast.get_dots_bef_aft s with
- Ast.NoDots -> ()
- | Ast.DroppingBetweenDots(stm,ind) -> let _ = statement stm in ()
- | Ast.AddingBetweenDots(stm,ind) -> let _ = statement stm in ()
-
- and statement s =
- process_bef_aft s;
- let k s =
- match Ast.unwrap s with
- Ast.Seq(lbrace,decls,body,rbrace) ->
- multibind [rule_elem lbrace; statement_dots decls;
- statement_dots body; rule_elem rbrace]
- | Ast.IfThen(header,branch,_) ->
- multibind [rule_elem header; statement branch]
- | Ast.IfThenElse(header,branch1,els,branch2,_) ->
- multibind [rule_elem header; statement branch1; rule_elem els;
- statement branch2]
- | Ast.While(header,body,_) ->
- multibind [rule_elem header; statement body]
- | Ast.Do(header,body,tail) ->
- multibind [rule_elem header; statement body; rule_elem tail]
- | Ast.For(header,body,_) -> multibind [rule_elem header; statement body]
- | Ast.Iterator(header,body,_) ->
- multibind [rule_elem header; statement body]
- | Ast.Switch(header,lb,cases,rb) ->
- multibind [rule_elem header;rule_elem lb;
- multibind (List.map case_line cases);
- rule_elem rb]
- | Ast.Atomic(re) -> rule_elem re
- | Ast.Disj(stmt_dots_list) ->
- multibind (List.map statement_dots stmt_dots_list)
- | Ast.Nest(stmt_dots,whn,_,_,_) ->
- bind (statement_dots stmt_dots)
- (multibind (List.map (whencode statement_dots statement) whn))
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- multibind [rule_elem header; rule_elem lbrace;
- statement_dots decls; statement_dots body;
- rule_elem rbrace]
- | Ast.Define(header,body) ->
- bind (rule_elem header) (statement_dots body)
- | Ast.Dots(d,whn,_,_) | Ast.Circles(d,whn,_,_) | Ast.Stars(d,whn,_,_) ->
- bind (string_mcode d)
- (multibind (List.map (whencode statement_dots statement) whn))
- | Ast.OptStm(stmt) | Ast.UniqueStm(stmt) ->
- statement stmt in
- stmtfn all_functions k s
-
- and fninfo = function
- Ast.FStorage(stg) -> storage_mcode stg
- | Ast.FType(ty) -> fullType ty
- | Ast.FInline(inline) -> string_mcode inline
- | Ast.FAttr(attr) -> string_mcode attr
-
- and whencode notfn alwaysfn = function
- Ast.WhenNot a -> notfn a
- | Ast.WhenAlways a -> alwaysfn a
- | Ast.WhenModifier(_) -> option_default
- | Ast.WhenNotTrue(e) -> rule_elem e
- | Ast.WhenNotFalse(e) -> rule_elem e
-
- and case_line c =
- let k c =
- match Ast.unwrap c with
- Ast.CaseLine(header,code) ->
- bind (rule_elem header) (statement_dots code)
- | Ast.OptCase(case) -> case_line case in
- casefn all_functions k c
-
- and top_level t =
- let k t =
- match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) ->
- bind (string_mcode old_file) (string_mcode new_file)
- | Ast.DECL(stmt) -> statement stmt
- | Ast.CODE(stmt_dots) -> statement_dots stmt_dots
- | Ast.ERRORWORDS(exps) -> multibind (List.map expression exps) in
- topfn all_functions k t
-
- and anything a =
- let k = function
- (*in many cases below, the thing is not even mcode, so we do nothing*)
- Ast.FullTypeTag(ft) -> fullType ft
- | Ast.BaseTypeTag(bt) -> option_default
- | Ast.StructUnionTag(su) -> option_default
- | Ast.SignTag(sgn) -> option_default
- | Ast.IdentTag(id) -> ident id
- | Ast.ExpressionTag(exp) -> expression exp
- | Ast.ConstantTag(cst) -> option_default
- | Ast.UnaryOpTag(unop) -> option_default
- | Ast.AssignOpTag(asgnop) -> option_default
- | Ast.FixOpTag(fixop) -> option_default
- | Ast.BinaryOpTag(binop) -> option_default
- | Ast.ArithOpTag(arithop) -> option_default
- | Ast.LogicalOpTag(logop) -> option_default
- | Ast.DeclarationTag(decl) -> declaration decl
- | Ast.InitTag(ini) -> initialiser ini
- | Ast.StorageTag(stg) -> option_default
- | Ast.IncFileTag(stg) -> option_default
- | Ast.Rule_elemTag(rule) -> rule_elem rule
- | Ast.StatementTag(rule) -> statement rule
- | Ast.CaseLineTag(case) -> case_line case
- | Ast.ConstVolTag(cv) -> option_default
- | Ast.Token(tok,info) -> option_default
- | Ast.Code(cd) -> top_level cd
- | Ast.ExprDotsTag(ed) -> expression_dots ed
- | Ast.ParamDotsTag(pd) -> parameter_dots pd
- | Ast.StmtDotsTag(sd) -> statement_dots sd
- | Ast.DeclDotsTag(sd) -> declaration_dots sd
- | Ast.TypeCTag(ty) -> typeC ty
- | Ast.ParamTag(param) -> parameterTypeDef param
- | Ast.SgrepStartTag(tok) -> option_default
- | Ast.SgrepEndTag(tok) -> option_default in
- anyfn all_functions k a
-
- and all_functions =
- {combiner_ident = ident;
- combiner_expression = expression;
- combiner_fullType = fullType;
- combiner_typeC = typeC;
- combiner_declaration = declaration;
- combiner_initialiser = initialiser;
- combiner_parameter = parameterTypeDef;
- combiner_parameter_list = parameter_dots;
- combiner_rule_elem = rule_elem;
- combiner_statement = statement;
- combiner_case_line = case_line;
- combiner_top_level = top_level;
- combiner_anything = anything;
- combiner_expression_dots = expression_dots;
- combiner_statement_dots = statement_dots;
- combiner_declaration_dots = declaration_dots} in
- all_functions
-
-(* ---------------------------------------------------------------------- *)
-
-type 'a inout = 'a -> 'a (* for specifying the type of rebuilder *)
-
-type rebuilder =
- {rebuilder_ident : Ast.ident inout;
- rebuilder_expression : Ast.expression inout;
- rebuilder_fullType : Ast.fullType inout;
- rebuilder_typeC : Ast.typeC inout;
- rebuilder_declaration : Ast.declaration inout;
- rebuilder_initialiser : Ast.initialiser inout;
- rebuilder_parameter : Ast.parameterTypeDef inout;
- rebuilder_parameter_list : Ast.parameter_list inout;
- rebuilder_statement : Ast.statement inout;
- rebuilder_case_line : Ast.case_line inout;
- rebuilder_rule_elem : Ast.rule_elem inout;
- rebuilder_top_level : Ast.top_level inout;
- rebuilder_expression_dots : Ast.expression Ast.dots inout;
- rebuilder_statement_dots : Ast.statement Ast.dots inout;
- rebuilder_declaration_dots : Ast.declaration Ast.dots inout;
- rebuilder_define_param_dots : Ast.define_param Ast.dots inout;
- rebuilder_define_param : Ast.define_param inout;
- rebuilder_define_parameters : Ast.define_parameters inout;
- rebuilder_anything : Ast.anything inout}
-
-type 'mc rmcode = 'mc Ast.mcode inout
-type 'cd rcode = rebuilder -> ('cd inout) -> 'cd inout
-
-
-let rebuilder
- meta_mcode string_mcode const_mcode assign_mcode fix_mcode unary_mcode
- binary_mcode cv_mcode sign_mcode struct_mcode storage_mcode
- inc_file_mcode
- expdotsfn paramdotsfn stmtdotsfn decldotsfn
- identfn exprfn ftfn tyfn initfn paramfn declfn rulefn stmtfn casefn
- topfn anyfn =
- let get_option f = function
- Some x -> Some (f x)
- | None -> None in
- let rec expression_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map expression l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map expression l)
- | Ast.STARS(l) -> Ast.STARS(List.map expression l)) in
- expdotsfn all_functions k d
-
- and parameter_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map parameterTypeDef l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map parameterTypeDef l)
- | Ast.STARS(l) -> Ast.STARS(List.map parameterTypeDef l)) in
- paramdotsfn all_functions k d
-
- and statement_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map statement l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map statement l)
- | Ast.STARS(l) -> Ast.STARS(List.map statement l)) in
- stmtdotsfn all_functions k d
-
- and declaration_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map declaration l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map declaration l)
- | Ast.STARS(l) -> Ast.STARS(List.map declaration l)) in
- decldotsfn all_functions k d
-
- and ident i =
- let k i =
- Ast.rewrap i
- (match Ast.unwrap i with
- Ast.Id(name) -> Ast.Id(string_mcode name)
- | Ast.MetaId(name,constraints,keep,inherited) ->
- Ast.MetaId(meta_mcode name,constraints,keep,inherited)
- | Ast.MetaFunc(name,constraints,keep,inherited) ->
- Ast.MetaFunc(meta_mcode name,constraints,keep,inherited)
- | Ast.MetaLocalFunc(name,constraints,keep,inherited) ->
- Ast.MetaLocalFunc(meta_mcode name,constraints,keep,inherited)
- | Ast.OptIdent(id) -> Ast.OptIdent(ident id)
- | Ast.UniqueIdent(id) -> Ast.UniqueIdent(ident id)) in
- identfn all_functions k i
-
- and expression e =
- let k e =
- Ast.rewrap e
- (match Ast.unwrap e with
- Ast.Ident(id) -> Ast.Ident(ident id)
- | Ast.Constant(const) -> Ast.Constant(const_mcode const)
- | Ast.FunCall(fn,lp,args,rp) ->
- Ast.FunCall(expression fn, string_mcode lp, expression_dots args,
- string_mcode rp)
- | Ast.Assignment(left,op,right,simple) ->
- Ast.Assignment(expression left, assign_mcode op, expression right,
- simple)
- | Ast.CondExpr(exp1,why,exp2,colon,exp3) ->
- Ast.CondExpr(expression exp1, string_mcode why,
- get_option expression exp2, string_mcode colon,
- expression exp3)
- | Ast.Postfix(exp,op) -> Ast.Postfix(expression exp,fix_mcode op)
- | Ast.Infix(exp,op) -> Ast.Infix(expression exp,fix_mcode op)
- | Ast.Unary(exp,op) -> Ast.Unary(expression exp,unary_mcode op)
- | Ast.Binary(left,op,right) ->
- Ast.Binary(expression left, binary_mcode op, expression right)
- | Ast.Nested(left,op,right) ->
- Ast.Nested(expression left, binary_mcode op, expression right)
- | Ast.Paren(lp,exp,rp) ->
- Ast.Paren(string_mcode lp, expression exp, string_mcode rp)
- | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
- Ast.ArrayAccess(expression exp1, string_mcode lb, expression exp2,
- string_mcode rb)
- | Ast.RecordAccess(exp,pt,field) ->
- Ast.RecordAccess(expression exp, string_mcode pt, ident field)
- | Ast.RecordPtAccess(exp,ar,field) ->
- Ast.RecordPtAccess(expression exp, string_mcode ar, ident field)
- | Ast.Cast(lp,ty,rp,exp) ->
- Ast.Cast(string_mcode lp, fullType ty, string_mcode rp,
- expression exp)
- | Ast.SizeOfExpr(szf,exp) ->
- Ast.SizeOfExpr(string_mcode szf, expression exp)
- | Ast.SizeOfType(szf,lp,ty,rp) ->
- Ast.SizeOfType(string_mcode szf,string_mcode lp, fullType ty,
- string_mcode rp)
- | Ast.TypeExp(ty) -> Ast.TypeExp(fullType ty)
- | Ast.MetaErr(name,constraints,keep,inherited) ->
- Ast.MetaErr(meta_mcode name,constraints,keep,inherited)
- | Ast.MetaExpr(name,constraints,keep,ty,form,inherited) ->
- Ast.MetaExpr(meta_mcode name,constraints,keep,ty,form,inherited)
- | Ast.MetaExprList(name,lenname_inh,keep,inherited) ->
- Ast.MetaExprList(meta_mcode name,lenname_inh,keep,inherited)
- | Ast.EComma(cm) -> Ast.EComma(string_mcode cm)
- | Ast.DisjExpr(exp_list) -> Ast.DisjExpr(List.map expression exp_list)
- | Ast.NestExpr(expr_dots,whencode,multi) ->
- Ast.NestExpr(expression_dots expr_dots,
- get_option expression whencode,multi)
- | Ast.Edots(dots,whencode) ->
- Ast.Edots(string_mcode dots,get_option expression whencode)
- | Ast.Ecircles(dots,whencode) ->
- Ast.Ecircles(string_mcode dots,get_option expression whencode)
- | Ast.Estars(dots,whencode) ->
- Ast.Estars(string_mcode dots,get_option expression whencode)
- | Ast.OptExp(exp) -> Ast.OptExp(expression exp)
- | Ast.UniqueExp(exp) -> Ast.UniqueExp(expression exp)) in
- exprfn all_functions k e
-
- and fullType ft =
- let k ft =
- Ast.rewrap ft
- (match Ast.unwrap ft with
- Ast.Type(cv,ty) -> Ast.Type (get_option cv_mcode cv, typeC ty)
- | Ast.DisjType(types) -> Ast.DisjType(List.map fullType types)
- | Ast.OptType(ty) -> Ast.OptType(fullType ty)
- | Ast.UniqueType(ty) -> Ast.UniqueType(fullType ty)) in
- ftfn all_functions k ft
-
- and typeC ty =
- let k ty =
- Ast.rewrap ty
- (match Ast.unwrap ty with
- Ast.BaseType(ty,strings) ->
- Ast.BaseType (ty, List.map string_mcode strings)
- | Ast.SignedT(sgn,ty) ->
- Ast.SignedT(sign_mcode sgn,get_option typeC ty)
- | Ast.Pointer(ty,star) ->
- Ast.Pointer (fullType ty, string_mcode star)
- | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- Ast.FunctionPointer(fullType ty,string_mcode lp1,string_mcode star,
- string_mcode rp1,string_mcode lp2,
- parameter_dots params,
- string_mcode rp2)
- | Ast.FunctionType(allminus,ty,lp,params,rp) ->
- Ast.FunctionType(allminus,get_option fullType ty,string_mcode lp,
- parameter_dots params,string_mcode rp)
- | Ast.Array(ty,lb,size,rb) ->
- Ast.Array(fullType ty, string_mcode lb,
- get_option expression size, string_mcode rb)
- | Ast.EnumName(kind,name) ->
- Ast.EnumName(string_mcode kind, ident name)
- | Ast.StructUnionName(kind,name) ->
- Ast.StructUnionName (struct_mcode kind, get_option ident name)
- | Ast.StructUnionDef(ty,lb,decls,rb) ->
- Ast.StructUnionDef (fullType ty,
- string_mcode lb, declaration_dots decls,
- string_mcode rb)
- | Ast.TypeName(name) -> Ast.TypeName(string_mcode name)
- | Ast.MetaType(name,keep,inherited) ->
- Ast.MetaType(meta_mcode name,keep,inherited)) in
- tyfn all_functions k ty
-
- and declaration d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.Init(stg,ty,id,eq,ini,sem) ->
- Ast.Init(get_option storage_mcode stg, fullType ty, ident id,
- string_mcode eq, initialiser ini, string_mcode sem)
- | Ast.UnInit(stg,ty,id,sem) ->
- Ast.UnInit(get_option storage_mcode stg, fullType ty, ident id,
- string_mcode sem)
- | Ast.MacroDecl(name,lp,args,rp,sem) ->
- Ast.MacroDecl(ident name, string_mcode lp, expression_dots args,
- string_mcode rp,string_mcode sem)
- | Ast.TyDecl(ty,sem) -> Ast.TyDecl(fullType ty, string_mcode sem)
- | Ast.Typedef(stg,ty,id,sem) ->
- Ast.Typedef(string_mcode stg, fullType ty, typeC id,
- string_mcode sem)
- | Ast.DisjDecl(decls) -> Ast.DisjDecl(List.map declaration decls)
- | Ast.Ddots(dots,whencode) ->
- Ast.Ddots(string_mcode dots, get_option declaration whencode)
- | Ast.MetaDecl(name,keep,inherited) ->
- Ast.MetaDecl(meta_mcode name,keep,inherited)
- | Ast.OptDecl(decl) -> Ast.OptDecl(declaration decl)
- | Ast.UniqueDecl(decl) -> Ast.UniqueDecl(declaration decl)) in
- declfn all_functions k d
-
- and initialiser i =
- let k i =
- Ast.rewrap i
- (match Ast.unwrap i with
- Ast.MetaInit(name,keep,inherited) ->
- Ast.MetaInit(meta_mcode name,keep,inherited)
- | Ast.InitExpr(exp) -> Ast.InitExpr(expression exp)
- | Ast.InitList(lb,initlist,rb,whencode) ->
- Ast.InitList(string_mcode lb, List.map initialiser initlist,
- string_mcode rb, List.map initialiser whencode)
- | Ast.InitGccName(name,eq,ini) ->
- Ast.InitGccName(ident name, string_mcode eq, initialiser ini)
- | Ast.InitGccExt(designators,eq,ini) ->
- Ast.InitGccExt
- (List.map designator designators, string_mcode eq,
- initialiser ini)
- | Ast.IComma(cm) -> Ast.IComma(string_mcode cm)
- | Ast.OptIni(i) -> Ast.OptIni(initialiser i)
- | Ast.UniqueIni(i) -> Ast.UniqueIni(initialiser i)) in
- initfn all_functions k i
-
- and designator = function
- Ast.DesignatorField(dot,id) ->
- Ast.DesignatorField(string_mcode dot,ident id)
- | Ast.DesignatorIndex(lb,exp,rb) ->
- Ast.DesignatorIndex(string_mcode lb,expression exp,string_mcode rb)
- | Ast.DesignatorRange(lb,min,dots,max,rb) ->
- Ast.DesignatorRange(string_mcode lb,expression min,string_mcode dots,
- expression max,string_mcode rb)
-
- and parameterTypeDef p =
- let k p =
- Ast.rewrap p
- (match Ast.unwrap p with
- Ast.VoidParam(ty) -> Ast.VoidParam(fullType ty)
- | Ast.Param(ty,id) -> Ast.Param(fullType ty, get_option ident id)
- | Ast.MetaParam(name,keep,inherited) ->
- Ast.MetaParam(meta_mcode name,keep,inherited)
- | Ast.MetaParamList(name,lenname_inh,keep,inherited) ->
- Ast.MetaParamList(meta_mcode name,lenname_inh,keep,inherited)
- | Ast.PComma(cm) -> Ast.PComma(string_mcode cm)
- | Ast.Pdots(dots) -> Ast.Pdots(string_mcode dots)
- | Ast.Pcircles(dots) -> Ast.Pcircles(string_mcode dots)
- | Ast.OptParam(param) -> Ast.OptParam(parameterTypeDef param)
- | Ast.UniqueParam(param) -> Ast.UniqueParam(parameterTypeDef param)) in
- paramfn all_functions k p
-
- and rule_elem re =
- let k re =
- Ast.rewrap re
- (match Ast.unwrap re with
- Ast.FunHeader(bef,allminus,fi,name,lp,params,rp) ->
- Ast.FunHeader(bef,allminus,List.map fninfo fi,ident name,
- string_mcode lp, parameter_dots params,
- string_mcode rp)
- | Ast.Decl(bef,allminus,decl) ->
- Ast.Decl(bef,allminus,declaration decl)
- | Ast.SeqStart(brace) -> Ast.SeqStart(string_mcode brace)
- | Ast.SeqEnd(brace) -> Ast.SeqEnd(string_mcode brace)
- | Ast.ExprStatement(exp,sem) ->
- Ast.ExprStatement (expression exp, string_mcode sem)
- | Ast.IfHeader(iff,lp,exp,rp) ->
- Ast.IfHeader(string_mcode iff, string_mcode lp, expression exp,
- string_mcode rp)
- | Ast.Else(els) -> Ast.Else(string_mcode els)
- | Ast.WhileHeader(whl,lp,exp,rp) ->
- Ast.WhileHeader(string_mcode whl, string_mcode lp, expression exp,
- string_mcode rp)
- | Ast.DoHeader(d) -> Ast.DoHeader(string_mcode d)
- | Ast.WhileTail(whl,lp,exp,rp,sem) ->
- Ast.WhileTail(string_mcode whl, string_mcode lp, expression exp,
- string_mcode rp, string_mcode sem)
- | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
- Ast.ForHeader(string_mcode fr, string_mcode lp,
- get_option expression e1, string_mcode sem1,
- get_option expression e2, string_mcode sem2,
- get_option expression e3, string_mcode rp)
- | Ast.IteratorHeader(whl,lp,args,rp) ->
- Ast.IteratorHeader(ident whl, string_mcode lp,
- expression_dots args, string_mcode rp)
- | Ast.SwitchHeader(switch,lp,exp,rp) ->
- Ast.SwitchHeader(string_mcode switch, string_mcode lp,
- expression exp, string_mcode rp)
- | Ast.Break(br,sem) ->
- Ast.Break(string_mcode br, string_mcode sem)
- | Ast.Continue(cont,sem) ->
- Ast.Continue(string_mcode cont, string_mcode sem)
- | Ast.Label(l,dd) -> Ast.Label(ident l, string_mcode dd)
- | Ast.Goto(goto,l,sem) ->
- Ast.Goto(string_mcode goto,ident l,string_mcode sem)
- | Ast.Return(ret,sem) ->
- Ast.Return(string_mcode ret, string_mcode sem)
- | Ast.ReturnExpr(ret,exp,sem) ->
- Ast.ReturnExpr(string_mcode ret, expression exp, string_mcode sem)
- | Ast.MetaStmt(name,keep,seqible,inherited) ->
- Ast.MetaStmt(meta_mcode name,keep,seqible,inherited)
- | Ast.MetaStmtList(name,keep,inherited) ->
- Ast.MetaStmtList(meta_mcode name,keep,inherited)
- | Ast.MetaRuleElem(name,keep,inherited) ->
- Ast.MetaRuleElem(meta_mcode name,keep,inherited)
- | Ast.Exp(exp) -> Ast.Exp(expression exp)
- | Ast.TopExp(exp) -> Ast.TopExp(expression exp)
- | Ast.Ty(ty) -> Ast.Ty(fullType ty)
- | Ast.TopInit(init) -> Ast.TopInit(initialiser init)
- | Ast.Include(inc,name) ->
- Ast.Include(string_mcode inc,inc_file_mcode name)
- | Ast.DefineHeader(def,id,params) ->
- Ast.DefineHeader(string_mcode def,ident id,
- define_parameters params)
- | Ast.Default(def,colon) ->
- Ast.Default(string_mcode def,string_mcode colon)
- | Ast.Case(case,exp,colon) ->
- Ast.Case(string_mcode case,expression exp,string_mcode colon)
- | Ast.DisjRuleElem(res) -> Ast.DisjRuleElem(List.map rule_elem res)) in
- rulefn all_functions k re
-
- (* not parameterizable for now... *)
- and define_parameters p =
- let k p =
- Ast.rewrap p
- (match Ast.unwrap p with
- Ast.NoParams -> Ast.NoParams
- | Ast.DParams(lp,params,rp) ->
- Ast.DParams(string_mcode lp,define_param_dots params,
- string_mcode rp)) in
- k p
-
- and define_param_dots d =
- let k d =
- Ast.rewrap d
- (match Ast.unwrap d with
- Ast.DOTS(l) -> Ast.DOTS(List.map define_param l)
- | Ast.CIRCLES(l) -> Ast.CIRCLES(List.map define_param l)
- | Ast.STARS(l) -> Ast.STARS(List.map define_param l)) in
- k d
-
- and define_param p =
- let k p =
- Ast.rewrap p
- (match Ast.unwrap p with
- Ast.DParam(id) -> Ast.DParam(ident id)
- | Ast.DPComma(comma) -> Ast.DPComma(string_mcode comma)
- | Ast.DPdots(d) -> Ast.DPdots(string_mcode d)
- | Ast.DPcircles(c) -> Ast.DPcircles(string_mcode c)
- | Ast.OptDParam(dp) -> Ast.OptDParam(define_param dp)
- | Ast.UniqueDParam(dp) -> Ast.UniqueDParam(define_param dp)) in
- k p
-
- and process_bef_aft s =
- Ast.set_dots_bef_aft
- (match Ast.get_dots_bef_aft s with
- Ast.NoDots -> Ast.NoDots
- | Ast.DroppingBetweenDots(stm,ind) ->
- Ast.DroppingBetweenDots(statement stm,ind)
- | Ast.AddingBetweenDots(stm,ind) ->
- Ast.AddingBetweenDots(statement stm,ind))
- s
-
- and statement s =
- let k s =
- Ast.rewrap s
- (match Ast.unwrap s with
- Ast.Seq(lbrace,decls,body,rbrace) ->
- Ast.Seq(rule_elem lbrace, statement_dots decls,
- statement_dots body, rule_elem rbrace)
- | Ast.IfThen(header,branch,aft) ->
- Ast.IfThen(rule_elem header, statement branch,aft)
- | Ast.IfThenElse(header,branch1,els,branch2,aft) ->
- Ast.IfThenElse(rule_elem header, statement branch1, rule_elem els,
- statement branch2, aft)
- | Ast.While(header,body,aft) ->
- Ast.While(rule_elem header, statement body, aft)
- | Ast.Do(header,body,tail) ->
- Ast.Do(rule_elem header, statement body, rule_elem tail)
- | Ast.For(header,body,aft) ->
- Ast.For(rule_elem header, statement body, aft)
- | Ast.Iterator(header,body,aft) ->
- Ast.Iterator(rule_elem header, statement body, aft)
- | Ast.Switch(header,lb,cases,rb) ->
- Ast.Switch(rule_elem header,rule_elem lb,
- List.map case_line cases,rule_elem rb)
- | Ast.Atomic(re) -> Ast.Atomic(rule_elem re)
- | Ast.Disj(stmt_dots_list) ->
- Ast.Disj (List.map statement_dots stmt_dots_list)
- | Ast.Nest(stmt_dots,whn,multi,bef,aft) ->
- Ast.Nest(statement_dots stmt_dots,
- List.map (whencode statement_dots statement) whn,
- multi,bef,aft)
- | Ast.FunDecl(header,lbrace,decls,body,rbrace) ->
- Ast.FunDecl(rule_elem header,rule_elem lbrace,
- statement_dots decls,
- statement_dots body, rule_elem rbrace)
- | Ast.Define(header,body) ->
- Ast.Define(rule_elem header,statement_dots body)
- | Ast.Dots(d,whn,bef,aft) ->
- Ast.Dots(string_mcode d,
- List.map (whencode statement_dots statement) whn,bef,aft)
- | Ast.Circles(d,whn,bef,aft) ->
- Ast.Circles(string_mcode d,
- List.map (whencode statement_dots statement) whn,
- bef,aft)
- | Ast.Stars(d,whn,bef,aft) ->
- Ast.Stars(string_mcode d,
- List.map (whencode statement_dots statement) whn,bef,aft)
- | Ast.OptStm(stmt) -> Ast.OptStm(statement stmt)
- | Ast.UniqueStm(stmt) -> Ast.UniqueStm(statement stmt)) in
- let s = stmtfn all_functions k s in
- (* better to do this after, in case there is an equality test on the whole
- statement, eg in free_vars. equality test would require that this
- subterm not already be changed *)
- process_bef_aft s
-
- and fninfo = function
- Ast.FStorage(stg) -> Ast.FStorage(storage_mcode stg)
- | Ast.FType(ty) -> Ast.FType(fullType ty)
- | Ast.FInline(inline) -> Ast.FInline(string_mcode inline)
- | Ast.FAttr(attr) -> Ast.FAttr(string_mcode attr)
-
- and whencode notfn alwaysfn = function
- Ast.WhenNot a -> Ast.WhenNot (notfn a)
- | Ast.WhenAlways a -> Ast.WhenAlways (alwaysfn a)
- | Ast.WhenModifier(x) -> Ast.WhenModifier(x)
- | Ast.WhenNotTrue(e) -> Ast.WhenNotTrue(rule_elem e)
- | Ast.WhenNotFalse(e) -> Ast.WhenNotFalse(rule_elem e)
-
- and case_line c =
- let k c =
- Ast.rewrap c
- (match Ast.unwrap c with
- Ast.CaseLine(header,code) ->
- Ast.CaseLine(rule_elem header,statement_dots code)
- | Ast.OptCase(case) -> Ast.OptCase(case_line case)) in
- casefn all_functions k c
-
- and top_level t =
- let k t =
- Ast.rewrap t
- (match Ast.unwrap t with
- Ast.FILEINFO(old_file,new_file) ->
- Ast.FILEINFO (string_mcode old_file, string_mcode new_file)
- | Ast.DECL(stmt) -> Ast.DECL(statement stmt)
- | Ast.CODE(stmt_dots) -> Ast.CODE(statement_dots stmt_dots)
- | Ast.ERRORWORDS(exps) -> Ast.ERRORWORDS (List.map expression exps)) in
- topfn all_functions k t
-
- and anything a =
- let k = function
- (*in many cases below, the thing is not even mcode, so we do nothing*)
- Ast.FullTypeTag(ft) -> Ast.FullTypeTag(fullType ft)
- | Ast.BaseTypeTag(bt) as x -> x
- | Ast.StructUnionTag(su) as x -> x
- | Ast.SignTag(sgn) as x -> x
- | Ast.IdentTag(id) -> Ast.IdentTag(ident id)
- | Ast.ExpressionTag(exp) -> Ast.ExpressionTag(expression exp)
- | Ast.ConstantTag(cst) as x -> x
- | Ast.UnaryOpTag(unop) as x -> x
- | Ast.AssignOpTag(asgnop) as x -> x
- | Ast.FixOpTag(fixop) as x -> x
- | Ast.BinaryOpTag(binop) as x -> x
- | Ast.ArithOpTag(arithop) as x -> x
- | Ast.LogicalOpTag(logop) as x -> x
- | Ast.InitTag(decl) -> Ast.InitTag(initialiser decl)
- | Ast.DeclarationTag(decl) -> Ast.DeclarationTag(declaration decl)
- | Ast.StorageTag(stg) as x -> x
- | Ast.IncFileTag(stg) as x -> x
- | Ast.Rule_elemTag(rule) -> Ast.Rule_elemTag(rule_elem rule)
- | Ast.StatementTag(rule) -> Ast.StatementTag(statement rule)
- | Ast.CaseLineTag(case) -> Ast.CaseLineTag(case_line case)
- | Ast.ConstVolTag(cv) as x -> x
- | Ast.Token(tok,info) as x -> x
- | Ast.Code(cd) -> Ast.Code(top_level cd)
- | Ast.ExprDotsTag(ed) -> Ast.ExprDotsTag(expression_dots ed)
- | Ast.ParamDotsTag(pd) -> Ast.ParamDotsTag(parameter_dots pd)
- | Ast.StmtDotsTag(sd) -> Ast.StmtDotsTag(statement_dots sd)
- | Ast.DeclDotsTag(sd) -> Ast.DeclDotsTag(declaration_dots sd)
- | Ast.TypeCTag(ty) -> Ast.TypeCTag(typeC ty)
- | Ast.ParamTag(param) -> Ast.ParamTag(parameterTypeDef param)
- | Ast.SgrepStartTag(tok) as x -> x
- | Ast.SgrepEndTag(tok) as x -> x in
- anyfn all_functions k a
-
- and all_functions =
- {rebuilder_ident = ident;
- rebuilder_expression = expression;
- rebuilder_fullType= fullType;
- rebuilder_typeC = typeC;
- rebuilder_declaration = declaration;
- rebuilder_initialiser = initialiser;
- rebuilder_parameter = parameterTypeDef;
- rebuilder_parameter_list = parameter_dots;
- rebuilder_rule_elem = rule_elem;
- rebuilder_statement = statement;
- rebuilder_case_line = case_line;
- rebuilder_top_level = top_level;
- rebuilder_expression_dots = expression_dots;
- rebuilder_statement_dots = statement_dots;
- rebuilder_declaration_dots = declaration_dots;
- rebuilder_define_param_dots = define_param_dots;
- rebuilder_define_param = define_param;
- rebuilder_define_parameters = define_parameters;
- rebuilder_anything = anything} in
- all_functions
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-module Ast = Ast_cocci
-module Ast0 = Ast0_cocci
-
-(* --------------------------------------------------------------------- *)
-(* Generic traversal: combiner *)
-(* parameters:
- combining function
- treatment of: mcode, identifiers, expressions, typeCs, types,
- declarations, statements, toplevels
- default value for options *)
-
-type 'a combiner =
- {combiner_ident : Ast0.ident -> 'a;
- combiner_expression : Ast0.expression -> 'a;
- combiner_typeC : Ast0.typeC -> 'a;
- combiner_declaration : Ast0.declaration -> 'a;
- combiner_initialiser : Ast0.initialiser -> 'a;
- combiner_initialiser_list : Ast0.initialiser_list -> 'a;
- combiner_parameter : Ast0.parameterTypeDef -> 'a;
- combiner_parameter_list : Ast0.parameter_list -> 'a;
- combiner_statement : Ast0.statement -> 'a;
- combiner_case_line : Ast0.case_line -> 'a;
- combiner_top_level : Ast0.top_level -> 'a;
- combiner_expression_dots :
- Ast0.expression Ast0.dots -> 'a;
- combiner_statement_dots :
- Ast0.statement Ast0.dots -> 'a;
- combiner_declaration_dots :
- Ast0.declaration Ast0.dots -> 'a;
- combiner_case_line_dots :
- Ast0.case_line Ast0.dots -> 'a;
- combiner_anything : Ast0.anything -> 'a}
-
-
-type ('mc,'a) cmcode = 'mc Ast0.mcode -> 'a
-type ('cd,'a) ccode = 'a combiner -> ('cd -> 'a) -> 'cd -> 'a
-
-let combiner bind option_default
- meta_mcode string_mcode const_mcode assign_mcode fix_mcode unary_mcode
- binary_mcode cv_mcode sign_mcode struct_mcode storage_mcode
- inc_mcode
- dotsexprfn dotsinitfn dotsparamfn dotsstmtfn dotsdeclfn dotscasefn
- identfn exprfn
- tyfn initfn paramfn declfn stmtfn casefn topfn =
- let multibind l =
- let rec loop = function
- [] -> option_default
- | [x] -> x
- | x::xs -> bind x (loop xs) in
- loop l in
- let get_option f = function
- Some x -> f x
- | None -> option_default in
- let rec expression_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map expression l) in
- dotsexprfn all_functions k d
- and initialiser_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map initialiser l) in
- dotsinitfn all_functions k d
- and parameter_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map parameterTypeDef l) in
- dotsparamfn all_functions k d
- and statement_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map statement l) in
- dotsstmtfn all_functions k d
- and declaration_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map declaration l) in
- dotsdeclfn all_functions k d
- and case_line_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map case_line l) in
- dotscasefn all_functions k d
- and ident i =
- let k i =
- match Ast0.unwrap i with
- Ast0.Id(name) -> string_mcode name
- | Ast0.MetaId(name,_,_) -> meta_mcode name
- | Ast0.MetaFunc(name,_,_) -> meta_mcode name
- | Ast0.MetaLocalFunc(name,_,_) -> meta_mcode name
- | Ast0.OptIdent(id) -> ident id
- | Ast0.UniqueIdent(id) -> ident id in
- identfn all_functions k i
- and expression e =
- let k e =
- match Ast0.unwrap e with
- Ast0.Ident(id) -> ident id
- | Ast0.Constant(const) -> const_mcode const
- | Ast0.FunCall(fn,lp,args,rp) ->
- multibind
- [expression fn; string_mcode lp; expression_dots args;
- string_mcode rp]
- | Ast0.Assignment(left,op,right,_) ->
- multibind [expression left; assign_mcode op; expression right]
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- multibind
- [expression exp1; string_mcode why; get_option expression exp2;
- string_mcode colon; expression exp3]
- | Ast0.Postfix(exp,op) -> bind (expression exp) (fix_mcode op)
- | Ast0.Infix(exp,op) -> bind (fix_mcode op) (expression exp)
- | Ast0.Unary(exp,op) -> bind (unary_mcode op) (expression exp)
- | Ast0.Binary(left,op,right) ->
- multibind [expression left; binary_mcode op; expression right]
- | Ast0.Nested(left,op,right) ->
- multibind [expression left; binary_mcode op; expression right]
- | Ast0.Paren(lp,exp,rp) ->
- multibind [string_mcode lp; expression exp; string_mcode rp]
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- multibind
- [expression exp1; string_mcode lb; expression exp2;
- string_mcode rb]
- | Ast0.RecordAccess(exp,pt,field) ->
- multibind [expression exp; string_mcode pt; ident field]
- | Ast0.RecordPtAccess(exp,ar,field) ->
- multibind [expression exp; string_mcode ar; ident field]
- | Ast0.Cast(lp,ty,rp,exp) ->
- multibind
- [string_mcode lp; typeC ty; string_mcode rp; expression exp]
- | Ast0.SizeOfExpr(szf,exp) ->
- multibind [string_mcode szf; expression exp]
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- multibind
- [string_mcode szf; string_mcode lp; typeC ty; string_mcode rp]
- | Ast0.TypeExp(ty) -> typeC ty
- | Ast0.MetaErr(name,_,_)
- | Ast0.MetaExpr(name,_,_,_,_)
- | Ast0.MetaExprList(name,_,_) -> meta_mcode name
- | Ast0.EComma(cm) -> string_mcode cm
- | Ast0.DisjExpr(starter,expr_list,mids,ender) ->
- (match expr_list with
- [] -> failwith "bad disjunction"
- | x::xs ->
- bind (string_mcode starter)
- (bind (expression x)
- (bind
- (multibind
- (List.map2
- (function mid ->
- function x ->
- bind (string_mcode mid) (expression x))
- mids xs))
- (string_mcode ender))))
- | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
- bind (string_mcode starter)
- (bind (expression_dots expr_dots)
- (bind (string_mcode ender) (get_option expression whencode)))
- | Ast0.Edots(dots,whencode) | Ast0.Ecircles(dots,whencode)
- | Ast0.Estars(dots,whencode) ->
- bind (string_mcode dots) (get_option expression whencode)
- | Ast0.OptExp(exp) -> expression exp
- | Ast0.UniqueExp(exp) -> expression exp in
- exprfn all_functions k e
- and function_pointer (ty,lp1,star,rp1,lp2,params,rp2) extra =
- (* have to put the treatment of the identifier into the right position *)
- multibind
- ([typeC ty; string_mcode lp1; string_mcode star] @ extra @
- [string_mcode rp1;
- string_mcode lp2; parameter_dots params; string_mcode rp2])
- and function_type (ty,lp1,params,rp1) extra =
- (* have to put the treatment of the identifier into the right position *)
- multibind ([get_option typeC ty] @ extra @
- [string_mcode lp1; parameter_dots params; string_mcode rp1])
- and array_type (ty,lb,size,rb) extra =
- multibind
- ([typeC ty] @ extra @
- [string_mcode lb; get_option expression size; string_mcode rb])
- and typeC t =
- let k t =
- match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) -> bind (cv_mcode cv) (typeC ty)
- | Ast0.BaseType(ty,strings) -> multibind (List.map string_mcode strings)
- | Ast0.Signed(sign,ty) -> bind (sign_mcode sign) (get_option typeC ty)
- | Ast0.Pointer(ty,star) -> bind (typeC ty) (string_mcode star)
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- function_pointer (ty,lp1,star,rp1,lp2,params,rp2) []
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- function_type (ty,lp1,params,rp1) []
- | Ast0.Array(ty,lb,size,rb) ->
- array_type (ty,lb,size,rb) []
- | Ast0.EnumName(kind,name) -> bind (string_mcode kind) (ident name)
- | Ast0.StructUnionName(kind,name) ->
- bind (struct_mcode kind) (get_option ident name)
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- multibind
- [typeC ty;string_mcode lb;declaration_dots decls;string_mcode rb]
- | Ast0.TypeName(name) -> string_mcode name
- | Ast0.MetaType(name,_) -> meta_mcode name
- | Ast0.DisjType(starter,types,mids,ender) ->
- (match types with
- [] -> failwith "bad disjunction"
- | x::xs ->
- bind (string_mcode starter)
- (bind (typeC x)
- (bind
- (multibind
- (List.map2
- (function mid ->
- function x ->
- bind (string_mcode mid) (typeC x))
- mids xs))
- (string_mcode ender))))
- | Ast0.OptType(ty) -> typeC ty
- | Ast0.UniqueType(ty) -> typeC ty in
- tyfn all_functions k t
- and named_type ty id =
- match Ast0.unwrap ty with
- Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- function_pointer (ty,lp1,star,rp1,lp2,params,rp2) [ident id]
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- function_type (ty,lp1,params,rp1) [ident id]
- | Ast0.Array(ty,lb,size,rb) ->
- array_type (ty,lb,size,rb) [ident id]
- | _ -> bind (typeC ty) (ident id)
- and declaration d =
- let k d =
- match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- bind (get_option storage_mcode stg)
- (bind (named_type ty id)
- (multibind
- [string_mcode eq; initialiser ini; string_mcode sem]))
- | Ast0.UnInit(stg,ty,id,sem) ->
- bind (get_option storage_mcode stg)
- (bind (named_type ty id) (string_mcode sem))
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- multibind
- [ident name; string_mcode lp; expression_dots args;
- string_mcode rp; string_mcode sem]
- | Ast0.TyDecl(ty,sem) -> bind (typeC ty) (string_mcode sem)
- | Ast0.Typedef(stg,ty,id,sem) ->
- bind (string_mcode stg)
- (bind (typeC ty) (bind (typeC id) (string_mcode sem)))
- | Ast0.DisjDecl(starter,decls,mids,ender) ->
- (match decls with
- [] -> failwith "bad disjunction"
- | x::xs ->
- bind (string_mcode starter)
- (bind (declaration x)
- (bind
- (multibind
- (List.map2
- (function mid ->
- function x ->
- bind (string_mcode mid) (declaration x))
- mids xs))
- (string_mcode ender))))
- | Ast0.Ddots(dots,whencode) ->
- bind (string_mcode dots) (get_option declaration whencode)
- | Ast0.OptDecl(decl) -> declaration decl
- | Ast0.UniqueDecl(decl) -> declaration decl in
- declfn all_functions k d
- and initialiser i =
- let k i =
- match Ast0.unwrap i with
- Ast0.InitExpr(exp) -> expression exp
- | Ast0.InitList(lb,initlist,rb) ->
- multibind
- [string_mcode lb; initialiser_dots initlist; string_mcode rb]
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- multibind
- [string_mcode dot; ident name; string_mcode eq; initialiser ini]
- | Ast0.InitGccName(name,eq,ini) ->
- multibind [ident name; string_mcode eq; initialiser ini]
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- multibind
- [string_mcode lb; expression exp; string_mcode rb;
- string_mcode eq; initialiser ini]
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- multibind
- [string_mcode lb; expression exp1; string_mcode dots;
- expression exp2; string_mcode rb; string_mcode eq;
- initialiser ini]
- | Ast0.IComma(cm) -> string_mcode cm
- | Ast0.Idots(dots,whencode) ->
- bind (string_mcode dots) (get_option initialiser whencode)
- | Ast0.OptIni(i) -> initialiser i
- | Ast0.UniqueIni(i) -> initialiser i in
- initfn all_functions k i
- and parameterTypeDef p =
- let k p =
- match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> typeC ty
- | Ast0.Param(ty,Some id) -> named_type ty id
- | Ast0.Param(ty,None) -> typeC ty
- | Ast0.MetaParam(name,_) -> meta_mcode name
- | Ast0.MetaParamList(name,_,_) -> meta_mcode name
- | Ast0.PComma(cm) -> string_mcode cm
- | Ast0.Pdots(dots) -> string_mcode dots
- | Ast0.Pcircles(dots) -> string_mcode dots
- | Ast0.OptParam(param) -> parameterTypeDef param
- | Ast0.UniqueParam(param) -> parameterTypeDef param in
- paramfn all_functions k p
-
- (* discard the result, because the statement is assumed to be already
- represented elsewhere in the code *)
- and process_bef_aft s =
- match Ast0.get_dots_bef_aft s with
- Ast0.NoDots -> ()
- | Ast0.DroppingBetweenDots(stm) -> let _ = statement stm in ()
- | Ast0.AddingBetweenDots(stm) -> let _ = statement stm in ()
-
- and statement s =
- process_bef_aft s;
- let k s =
- match Ast0.unwrap s with
- Ast0.FunDecl(_,fi,name,lp,params,rp,lbrace,body,rbrace) ->
- multibind
- ((List.map fninfo fi) @
- [ident name; string_mcode lp;
- parameter_dots params; string_mcode rp; string_mcode lbrace;
- statement_dots body; string_mcode rbrace])
- | Ast0.Decl(_,decl) -> declaration decl
- | Ast0.Seq(lbrace,body,rbrace) ->
- multibind
- [string_mcode lbrace; statement_dots body; string_mcode rbrace]
- | Ast0.ExprStatement(exp,sem) ->
- bind (expression exp) (string_mcode sem)
- | Ast0.IfThen(iff,lp,exp,rp,branch1,_) ->
- multibind
- [string_mcode iff; string_mcode lp; expression exp;
- string_mcode rp; statement branch1]
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,_) ->
- multibind
- [string_mcode iff; string_mcode lp; expression exp;
- string_mcode rp; statement branch1; string_mcode els;
- statement branch2]
- | Ast0.While(whl,lp,exp,rp,body,_) ->
- multibind
- [string_mcode whl; string_mcode lp; expression exp;
- string_mcode rp; statement body]
- | Ast0.Do(d,body,whl,lp,exp,rp,sem) ->
- multibind
- [string_mcode d; statement body; string_mcode whl;
- string_mcode lp; expression exp; string_mcode rp;
- string_mcode sem]
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,_) ->
- multibind
- [string_mcode fr; string_mcode lp; get_option expression e1;
- string_mcode sem1; get_option expression e2; string_mcode sem2;
- get_option expression e3;
- string_mcode rp; statement body]
- | Ast0.Iterator(nm,lp,args,rp,body,_) ->
- multibind
- [ident nm; string_mcode lp; expression_dots args;
- string_mcode rp; statement body]
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- multibind
- [string_mcode switch; string_mcode lp; expression exp;
- string_mcode rp; string_mcode lb; case_line_dots cases;
- string_mcode rb]
- | Ast0.Break(br,sem) -> bind (string_mcode br) (string_mcode sem)
- | Ast0.Continue(cont,sem) -> bind (string_mcode cont) (string_mcode sem)
- | Ast0.Label(l,dd) -> bind (ident l) (string_mcode dd)
- | Ast0.Goto(goto,l,sem) ->
- bind (string_mcode goto) (bind (ident l) (string_mcode sem))
- | Ast0.Return(ret,sem) -> bind (string_mcode ret) (string_mcode sem)
- | Ast0.ReturnExpr(ret,exp,sem) ->
- multibind [string_mcode ret; expression exp; string_mcode sem]
- | Ast0.MetaStmt(name,_) -> meta_mcode name
- | Ast0.MetaStmtList(name,_) -> meta_mcode name
- | Ast0.Disj(starter,statement_dots_list,mids,ender) ->
- (match statement_dots_list with
- [] -> failwith "bad disjunction"
- | x::xs ->
- bind (string_mcode starter)
- (bind (statement_dots x)
- (bind
- (multibind
- (List.map2
- (function mid ->
- function x ->
- bind (string_mcode mid) (statement_dots x))
- mids xs))
- (string_mcode ender))))
- | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
- bind (string_mcode starter)
- (bind (statement_dots stmt_dots)
- (bind (string_mcode ender)
- (multibind
- (List.map (whencode statement_dots statement) whn))))
- | Ast0.Exp(exp) -> expression exp
- | Ast0.TopExp(exp) -> expression exp
- | Ast0.Ty(ty) -> typeC ty
- | Ast0.TopInit(init) -> initialiser init
- | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
- bind (string_mcode d)
- (multibind (List.map (whencode statement_dots statement) whn))
- | Ast0.Include(inc,name) -> bind (string_mcode inc) (inc_mcode name)
- | Ast0.Define(def,id,params,body) ->
- multibind [string_mcode def; ident id; define_parameters params;
- statement_dots body]
- | Ast0.OptStm(re) -> statement re
- | Ast0.UniqueStm(re) -> statement re in
- stmtfn all_functions k s
-
- (* not parameterizable for now... *)
- and define_parameters p =
- let k p =
- match Ast0.unwrap p with
- Ast0.NoParams -> option_default
- | Ast0.DParams(lp,params,rp) ->
- multibind
- [string_mcode lp; define_param_dots params; string_mcode rp] in
- k p
-
- and define_param_dots d =
- let k d =
- match Ast0.unwrap d with
- Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) ->
- multibind (List.map define_param l) in
- k d
-
- and define_param p =
- let k p =
- match Ast0.unwrap p with
- Ast0.DParam(id) -> ident id
- | Ast0.DPComma(comma) -> string_mcode comma
- | Ast0.DPdots(d) -> string_mcode d
- | Ast0.DPcircles(c) -> string_mcode c
- | Ast0.OptDParam(dp) -> define_param dp
- | Ast0.UniqueDParam(dp) -> define_param dp in
- k p
-
- and fninfo = function
- Ast0.FStorage(stg) -> storage_mcode stg
- | Ast0.FType(ty) -> typeC ty
- | Ast0.FInline(inline) -> string_mcode inline
- | Ast0.FAttr(init) -> string_mcode init
-
- and whencode notfn alwaysfn = function
- Ast0.WhenNot a -> notfn a
- | Ast0.WhenAlways a -> alwaysfn a
- | Ast0.WhenModifier(_) -> option_default
- | Ast0.WhenNotTrue(e) -> expression e
- | Ast0.WhenNotFalse(e) -> expression e
-
- and case_line c =
- let k c =
- match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- multibind [string_mcode def;string_mcode colon;statement_dots code]
- | Ast0.Case(case,exp,colon,code) ->
- multibind [string_mcode case;expression exp;string_mcode colon;
- statement_dots code]
- | Ast0.OptCase(case) -> case_line case in
- casefn all_functions k c
-
- and anything a = (* for compile_iso, not parameterisable *)
- let k = function
- Ast0.DotsExprTag(exprs) -> expression_dots exprs
- | Ast0.DotsInitTag(inits) -> initialiser_dots inits
- | Ast0.DotsParamTag(params) -> parameter_dots params
- | Ast0.DotsStmtTag(stmts) -> statement_dots stmts
- | Ast0.DotsDeclTag(decls) -> declaration_dots decls
- | Ast0.DotsCaseTag(cases) -> case_line_dots cases
- | Ast0.IdentTag(id) -> ident id
- | Ast0.ExprTag(exp) -> expression exp
- | Ast0.ArgExprTag(exp) -> expression exp
- | Ast0.TestExprTag(exp) -> expression exp
- | Ast0.TypeCTag(ty) -> typeC ty
- | Ast0.ParamTag(param) -> parameterTypeDef param
- | Ast0.InitTag(init) -> initialiser init
- | Ast0.DeclTag(decl) -> declaration decl
- | Ast0.StmtTag(stmt) -> statement stmt
- | Ast0.CaseLineTag(c) -> case_line c
- | Ast0.TopTag(top) -> top_level top
- | Ast0.IsoWhenTag(_) -> option_default
- | Ast0.IsoWhenTTag(e) -> expression e
- | Ast0.IsoWhenFTag(e) -> expression e
- | Ast0.MetaPosTag(var) -> failwith "not supported" in
- k a
-
- and top_level t =
- let k t =
- match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- bind (string_mcode old_file) (string_mcode new_file)
- | Ast0.DECL(stmt_dots) -> statement stmt_dots
- | Ast0.CODE(stmt_dots) -> statement_dots stmt_dots
- | Ast0.ERRORWORDS(exps) -> multibind (List.map expression exps)
- | Ast0.OTHER(_) -> failwith "unexpected code" in
- topfn all_functions k t
- and all_functions =
- {combiner_ident = ident;
- combiner_expression = expression;
- combiner_typeC = typeC;
- combiner_declaration = declaration;
- combiner_initialiser = initialiser;
- combiner_initialiser_list = initialiser_dots;
- combiner_parameter = parameterTypeDef;
- combiner_parameter_list = parameter_dots;
- combiner_statement = statement;
- combiner_case_line = case_line;
- combiner_top_level = top_level;
- combiner_expression_dots = expression_dots;
- combiner_statement_dots = statement_dots;
- combiner_declaration_dots = declaration_dots;
- combiner_case_line_dots = case_line_dots;
- combiner_anything = anything} in
- all_functions
-
-(* --------------------------------------------------------------------- *)
-(* Generic traversal: rebuilder *)
-
-type 'a inout = 'a -> 'a (* for specifying the type of rebuilder *)
-
-type rebuilder =
- {rebuilder_ident : Ast0.ident inout;
- rebuilder_expression : Ast0.expression inout;
- rebuilder_typeC : Ast0.typeC inout;
- rebuilder_declaration : Ast0.declaration inout;
- rebuilder_initialiser : Ast0.initialiser inout;
- rebuilder_initialiser_list : Ast0.initialiser_list inout;
- rebuilder_parameter : Ast0.parameterTypeDef inout;
- rebuilder_parameter_list : Ast0.parameter_list inout;
- rebuilder_statement : Ast0.statement inout;
- rebuilder_case_line : Ast0.case_line inout;
- rebuilder_top_level : Ast0.top_level inout;
- rebuilder_expression_dots :
- Ast0.expression Ast0.dots ->
- Ast0.expression Ast0.dots;
- rebuilder_statement_dots :
- Ast0.statement Ast0.dots ->
- Ast0.statement Ast0.dots;
- rebuilder_declaration_dots :
- Ast0.declaration Ast0.dots ->
- Ast0.declaration Ast0.dots;
- rebuilder_case_line_dots :
- Ast0.case_line Ast0.dots ->
- Ast0.case_line Ast0.dots;
- rebuilder_anything :
- Ast0.anything -> Ast0.anything}
-
-type 'mc rmcode = 'mc Ast0.mcode inout
-type 'cd rcode = rebuilder -> ('cd inout) -> 'cd inout
-
-let rebuilder = fun
- meta_mcode string_mcode const_mcode assign_mcode fix_mcode unary_mcode
- binary_mcode cv_mcode sign_mcode struct_mcode storage_mcode
- inc_mcode
- dotsexprfn dotsinitfn dotsparamfn dotsstmtfn dotsdeclfn dotscasefn
- identfn exprfn tyfn initfn paramfn declfn stmtfn casefn topfn ->
- let get_option f = function
- Some x -> Some (f x)
- | None -> None in
- let rec expression_dots d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map expression l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map expression l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map expression l)) in
- dotsexprfn all_functions k d
- and initialiser_list i =
- let k i =
- Ast0.rewrap i
- (match Ast0.unwrap i with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map initialiser l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map initialiser l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map initialiser l)) in
- dotsinitfn all_functions k i
- and parameter_list d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map parameterTypeDef l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map parameterTypeDef l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map parameterTypeDef l)) in
- dotsparamfn all_functions k d
- and statement_dots d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map statement l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map statement l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map statement l)) in
- dotsstmtfn all_functions k d
- and declaration_dots d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map declaration l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map declaration l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map declaration l)) in
- dotsdeclfn all_functions k d
- and case_line_dots d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map case_line l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map case_line l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map case_line l)) in
- dotscasefn all_functions k d
- and ident i =
- let k i =
- Ast0.rewrap i
- (match Ast0.unwrap i with
- Ast0.Id(name) -> Ast0.Id(string_mcode name)
- | Ast0.MetaId(name,constraints,pure) ->
- Ast0.MetaId(meta_mcode name,constraints,pure)
- | Ast0.MetaFunc(name,constraints,pure) ->
- Ast0.MetaFunc(meta_mcode name,constraints,pure)
- | Ast0.MetaLocalFunc(name,constraints,pure) ->
- Ast0.MetaLocalFunc(meta_mcode name,constraints,pure)
- | Ast0.OptIdent(id) -> Ast0.OptIdent(ident id)
- | Ast0.UniqueIdent(id) -> Ast0.UniqueIdent(ident id)) in
- identfn all_functions k i
- and expression e =
- let k e =
- Ast0.rewrap e
- (match Ast0.unwrap e with
- Ast0.Ident(id) -> Ast0.Ident(ident id)
- | Ast0.Constant(const) -> Ast0.Constant(const_mcode const)
- | Ast0.FunCall(fn,lp,args,rp) ->
- Ast0.FunCall(expression fn,string_mcode lp,expression_dots args,
- string_mcode rp)
- | Ast0.Assignment(left,op,right,simple) ->
- Ast0.Assignment(expression left,assign_mcode op,expression right,
- simple)
- | Ast0.CondExpr(exp1,why,exp2,colon,exp3) ->
- Ast0.CondExpr(expression exp1, string_mcode why,
- get_option expression exp2, string_mcode colon,
- expression exp3)
- | Ast0.Postfix(exp,op) -> Ast0.Postfix(expression exp, fix_mcode op)
- | Ast0.Infix(exp,op) -> Ast0.Infix(expression exp, fix_mcode op)
- | Ast0.Unary(exp,op) -> Ast0.Unary(expression exp, unary_mcode op)
- | Ast0.Binary(left,op,right) ->
- Ast0.Binary(expression left, binary_mcode op, expression right)
- | Ast0.Nested(left,op,right) ->
- Ast0.Nested(expression left, binary_mcode op, expression right)
- | Ast0.Paren(lp,exp,rp) ->
- Ast0.Paren(string_mcode lp, expression exp, string_mcode rp)
- | Ast0.ArrayAccess(exp1,lb,exp2,rb) ->
- Ast0.ArrayAccess(expression exp1,string_mcode lb,expression exp2,
- string_mcode rb)
- | Ast0.RecordAccess(exp,pt,field) ->
- Ast0.RecordAccess(expression exp, string_mcode pt, ident field)
- | Ast0.RecordPtAccess(exp,ar,field) ->
- Ast0.RecordPtAccess(expression exp, string_mcode ar, ident field)
- | Ast0.Cast(lp,ty,rp,exp) ->
- Ast0.Cast(string_mcode lp, typeC ty, string_mcode rp,
- expression exp)
- | Ast0.SizeOfExpr(szf,exp) ->
- Ast0.SizeOfExpr(string_mcode szf, expression exp)
- | Ast0.SizeOfType(szf,lp,ty,rp) ->
- Ast0.SizeOfType(string_mcode szf,string_mcode lp, typeC ty,
- string_mcode rp)
- | Ast0.TypeExp(ty) -> Ast0.TypeExp(typeC ty)
- | Ast0.MetaErr(name,constraints,pure) ->
- Ast0.MetaErr(meta_mcode name,constraints,pure)
- | Ast0.MetaExpr(name,constraints,ty,form,pure) ->
- Ast0.MetaExpr(meta_mcode name,constraints,ty,form,pure)
- | Ast0.MetaExprList(name,lenname,pure) ->
- Ast0.MetaExprList(meta_mcode name,lenname,pure)
- | Ast0.EComma(cm) -> Ast0.EComma(string_mcode cm)
- | Ast0.DisjExpr(starter,expr_list,mids,ender) ->
- Ast0.DisjExpr(string_mcode starter,List.map expression expr_list,
- List.map string_mcode mids,string_mcode ender)
- | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
- Ast0.NestExpr(string_mcode starter,expression_dots expr_dots,
- string_mcode ender, get_option expression whencode,
- multi)
- | Ast0.Edots(dots,whencode) ->
- Ast0.Edots(string_mcode dots, get_option expression whencode)
- | Ast0.Ecircles(dots,whencode) ->
- Ast0.Ecircles(string_mcode dots, get_option expression whencode)
- | Ast0.Estars(dots,whencode) ->
- Ast0.Estars(string_mcode dots, get_option expression whencode)
- | Ast0.OptExp(exp) -> Ast0.OptExp(expression exp)
- | Ast0.UniqueExp(exp) -> Ast0.UniqueExp(expression exp)) in
- exprfn all_functions k e
- and typeC t =
- let k t =
- Ast0.rewrap t
- (match Ast0.unwrap t with
- Ast0.ConstVol(cv,ty) -> Ast0.ConstVol(cv_mcode cv,typeC ty)
- | Ast0.BaseType(ty,strings) ->
- Ast0.BaseType(ty, List.map string_mcode strings)
- | Ast0.Signed(sign,ty) ->
- Ast0.Signed(sign_mcode sign,get_option typeC ty)
- | Ast0.Pointer(ty,star) ->
- Ast0.Pointer(typeC ty, string_mcode star)
- | Ast0.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
- Ast0.FunctionPointer(typeC ty,string_mcode lp1,string_mcode star,
- string_mcode rp1,string_mcode lp2,
- parameter_list params,
- string_mcode rp2)
- | Ast0.FunctionType(ty,lp1,params,rp1) ->
- Ast0.FunctionType(get_option typeC ty,
- string_mcode lp1,parameter_list params,
- string_mcode rp1)
- | Ast0.Array(ty,lb,size,rb) ->
- Ast0.Array(typeC ty, string_mcode lb,
- get_option expression size, string_mcode rb)
- | Ast0.EnumName(kind,name) ->
- Ast0.EnumName(string_mcode kind, ident name)
- | Ast0.StructUnionName(kind,name) ->
- Ast0.StructUnionName (struct_mcode kind, get_option ident name)
- | Ast0.StructUnionDef(ty,lb,decls,rb) ->
- Ast0.StructUnionDef (typeC ty,
- string_mcode lb, declaration_dots decls,
- string_mcode rb)
- | Ast0.TypeName(name) -> Ast0.TypeName(string_mcode name)
- | Ast0.MetaType(name,pure) ->
- Ast0.MetaType(meta_mcode name,pure)
- | Ast0.DisjType(starter,types,mids,ender) ->
- Ast0.DisjType(string_mcode starter,List.map typeC types,
- List.map string_mcode mids,string_mcode ender)
- | Ast0.OptType(ty) -> Ast0.OptType(typeC ty)
- | Ast0.UniqueType(ty) -> Ast0.UniqueType(typeC ty)) in
- tyfn all_functions k t
- and declaration d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.Init(stg,ty,id,eq,ini,sem) ->
- Ast0.Init(get_option storage_mcode stg,
- typeC ty, ident id, string_mcode eq, initialiser ini,
- string_mcode sem)
- | Ast0.UnInit(stg,ty,id,sem) ->
- Ast0.UnInit(get_option storage_mcode stg,
- typeC ty, ident id, string_mcode sem)
- | Ast0.MacroDecl(name,lp,args,rp,sem) ->
- Ast0.MacroDecl(ident name,string_mcode lp,
- expression_dots args,
- string_mcode rp,string_mcode sem)
- | Ast0.TyDecl(ty,sem) -> Ast0.TyDecl(typeC ty, string_mcode sem)
- | Ast0.Typedef(stg,ty,id,sem) ->
- Ast0.Typedef(string_mcode stg, typeC ty, typeC id,
- string_mcode sem)
- | Ast0.DisjDecl(starter,decls,mids,ender) ->
- Ast0.DisjDecl(string_mcode starter,List.map declaration decls,
- List.map string_mcode mids,string_mcode ender)
- | Ast0.Ddots(dots,whencode) ->
- Ast0.Ddots(string_mcode dots, get_option declaration whencode)
- | Ast0.OptDecl(decl) -> Ast0.OptDecl(declaration decl)
- | Ast0.UniqueDecl(decl) -> Ast0.UniqueDecl(declaration decl)) in
- declfn all_functions k d
- and initialiser i =
- let k i =
- Ast0.rewrap i
- (match Ast0.unwrap i with
- Ast0.InitExpr(exp) -> Ast0.InitExpr(expression exp)
- | Ast0.InitList(lb,initlist,rb) ->
- Ast0.InitList(string_mcode lb, initialiser_list initlist,
- string_mcode rb)
- | Ast0.InitGccDotName(dot,name,eq,ini) ->
- Ast0.InitGccDotName
- (string_mcode dot, ident name, string_mcode eq, initialiser ini)
- | Ast0.InitGccName(name,eq,ini) ->
- Ast0.InitGccName(ident name, string_mcode eq, initialiser ini)
- | Ast0.InitGccIndex(lb,exp,rb,eq,ini) ->
- Ast0.InitGccIndex
- (string_mcode lb, expression exp, string_mcode rb,
- string_mcode eq, initialiser ini)
- | Ast0.InitGccRange(lb,exp1,dots,exp2,rb,eq,ini) ->
- Ast0.InitGccRange
- (string_mcode lb, expression exp1, string_mcode dots,
- expression exp2, string_mcode rb, string_mcode eq,
- initialiser ini)
- | Ast0.IComma(cm) -> Ast0.IComma(string_mcode cm)
- | Ast0.Idots(d,whencode) ->
- Ast0.Idots(string_mcode d, get_option initialiser whencode)
- | Ast0.OptIni(i) -> Ast0.OptIni(initialiser i)
- | Ast0.UniqueIni(i) -> Ast0.UniqueIni(initialiser i)) in
- initfn all_functions k i
- and parameterTypeDef p =
- let k p =
- Ast0.rewrap p
- (match Ast0.unwrap p with
- Ast0.VoidParam(ty) -> Ast0.VoidParam(typeC ty)
- | Ast0.Param(ty,id) -> Ast0.Param(typeC ty, get_option ident id)
- | Ast0.MetaParam(name,pure) ->
- Ast0.MetaParam(meta_mcode name,pure)
- | Ast0.MetaParamList(name,lenname,pure) ->
- Ast0.MetaParamList(meta_mcode name,lenname,pure)
- | Ast0.PComma(cm) -> Ast0.PComma(string_mcode cm)
- | Ast0.Pdots(dots) -> Ast0.Pdots(string_mcode dots)
- | Ast0.Pcircles(dots) -> Ast0.Pcircles(string_mcode dots)
- | Ast0.OptParam(param) -> Ast0.OptParam(parameterTypeDef param)
- | Ast0.UniqueParam(param) ->
- Ast0.UniqueParam(parameterTypeDef param)) in
- paramfn all_functions k p
- (* not done for combiner, because the statement is assumed to be already
- represented elsewhere in the code *)
- and process_bef_aft s =
- Ast0.set_dots_bef_aft s
- (match Ast0.get_dots_bef_aft s with
- Ast0.NoDots -> Ast0.NoDots
- | Ast0.DroppingBetweenDots(stm) ->
- Ast0.DroppingBetweenDots(statement stm)
- | Ast0.AddingBetweenDots(stm) ->
- Ast0.AddingBetweenDots(statement stm))
-
- and statement s =
- let k s =
- Ast0.rewrap s
- (match Ast0.unwrap s with
- Ast0.FunDecl(bef,fi,name,lp,params,rp,lbrace,body,rbrace) ->
- Ast0.FunDecl(bef,List.map fninfo fi, ident name,
- string_mcode lp, parameter_list params,
- string_mcode rp, string_mcode lbrace,
- statement_dots body, string_mcode rbrace)
- | Ast0.Decl(bef,decl) -> Ast0.Decl(bef,declaration decl)
- | Ast0.Seq(lbrace,body,rbrace) ->
- Ast0.Seq(string_mcode lbrace, statement_dots body,
- string_mcode rbrace)
- | Ast0.ExprStatement(exp,sem) ->
- Ast0.ExprStatement(expression exp, string_mcode sem)
- | Ast0.IfThen(iff,lp,exp,rp,branch1,aft) ->
- Ast0.IfThen(string_mcode iff, string_mcode lp, expression exp,
- string_mcode rp, statement branch1,aft)
- | Ast0.IfThenElse(iff,lp,exp,rp,branch1,els,branch2,aft) ->
- Ast0.IfThenElse(string_mcode iff,string_mcode lp,expression exp,
- string_mcode rp, statement branch1, string_mcode els,
- statement branch2,aft)
- | Ast0.While(whl,lp,exp,rp,body,aft) ->
- Ast0.While(string_mcode whl, string_mcode lp, expression exp,
- string_mcode rp, statement body, aft)
- | Ast0.Do(d,body,whl,lp,exp,rp,sem) ->
- Ast0.Do(string_mcode d, statement body, string_mcode whl,
- string_mcode lp, expression exp, string_mcode rp,
- string_mcode sem)
- | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,aft) ->
- Ast0.For(string_mcode fr, string_mcode lp,
- get_option expression e1, string_mcode sem1,
- get_option expression e2, string_mcode sem2,
- get_option expression e3,
- string_mcode rp, statement body, aft)
- | Ast0.Iterator(nm,lp,args,rp,body,aft) ->
- Ast0.Iterator(ident nm, string_mcode lp,
- expression_dots args,
- string_mcode rp, statement body, aft)
- | Ast0.Switch(switch,lp,exp,rp,lb,cases,rb) ->
- Ast0.Switch(string_mcode switch,string_mcode lp,expression exp,
- string_mcode rp,string_mcode lb,
- case_line_dots cases, string_mcode rb)
- | Ast0.Break(br,sem) ->
- Ast0.Break(string_mcode br,string_mcode sem)
- | Ast0.Continue(cont,sem) ->
- Ast0.Continue(string_mcode cont,string_mcode sem)
- | Ast0.Label(l,dd) -> Ast0.Label(ident l,string_mcode dd)
- | Ast0.Goto(goto,l,sem) ->
- Ast0.Goto(string_mcode goto,ident l,string_mcode sem)
- | Ast0.Return(ret,sem) ->
- Ast0.Return(string_mcode ret,string_mcode sem)
- | Ast0.ReturnExpr(ret,exp,sem) ->
- Ast0.ReturnExpr(string_mcode ret,expression exp,string_mcode sem)
- | Ast0.MetaStmt(name,pure) ->
- Ast0.MetaStmt(meta_mcode name,pure)
- | Ast0.MetaStmtList(name,pure) ->
- Ast0.MetaStmtList(meta_mcode name,pure)
- | Ast0.Disj(starter,statement_dots_list,mids,ender) ->
- Ast0.Disj(string_mcode starter,
- List.map statement_dots statement_dots_list,
- List.map string_mcode mids,
- string_mcode ender)
- | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
- Ast0.Nest(string_mcode starter,statement_dots stmt_dots,
- string_mcode ender,
- List.map (whencode statement_dots statement) whn,
- multi)
- | Ast0.Exp(exp) -> Ast0.Exp(expression exp)
- | Ast0.TopExp(exp) -> Ast0.TopExp(expression exp)
- | Ast0.Ty(ty) -> Ast0.Ty(typeC ty)
- | Ast0.TopInit(init) -> Ast0.TopInit(initialiser init)
- | Ast0.Dots(d,whn) ->
- Ast0.Dots(string_mcode d,
- List.map (whencode statement_dots statement) whn)
- | Ast0.Circles(d,whn) ->
- Ast0.Circles(string_mcode d,
- List.map (whencode statement_dots statement) whn)
- | Ast0.Stars(d,whn) ->
- Ast0.Stars(string_mcode d,
- List.map (whencode statement_dots statement) whn)
- | Ast0.Include(inc,name) ->
- Ast0.Include(string_mcode inc,inc_mcode name)
- | Ast0.Define(def,id,params,body) ->
- Ast0.Define(string_mcode def,ident id,
- define_parameters params,
- statement_dots body)
- | Ast0.OptStm(re) -> Ast0.OptStm(statement re)
- | Ast0.UniqueStm(re) -> Ast0.UniqueStm(statement re)) in
- let s = stmtfn all_functions k s in
- process_bef_aft s
-
- (* not parameterizable for now... *)
- and define_parameters p =
- let k p =
- Ast0.rewrap p
- (match Ast0.unwrap p with
- Ast0.NoParams -> Ast0.NoParams
- | Ast0.DParams(lp,params,rp) ->
- Ast0.DParams(string_mcode lp,define_param_dots params,
- string_mcode rp))in
- k p
-
- and define_param_dots d =
- let k d =
- Ast0.rewrap d
- (match Ast0.unwrap d with
- Ast0.DOTS(l) -> Ast0.DOTS(List.map define_param l)
- | Ast0.CIRCLES(l) -> Ast0.CIRCLES(List.map define_param l)
- | Ast0.STARS(l) -> Ast0.STARS(List.map define_param l)) in
- k d
-
- and define_param p =
- let k p =
- Ast0.rewrap p
- (match Ast0.unwrap p with
- Ast0.DParam(id) -> Ast0.DParam(ident id)
- | Ast0.DPComma(comma) -> Ast0.DPComma(string_mcode comma)
- | Ast0.DPdots(d) -> Ast0.DPdots(string_mcode d)
- | Ast0.DPcircles(c) -> Ast0.DPcircles(string_mcode c)
- | Ast0.OptDParam(dp) -> Ast0.OptDParam(define_param dp)
- | Ast0.UniqueDParam(dp) -> Ast0.UniqueDParam(define_param dp)) in
- k p
-
- and fninfo = function
- Ast0.FStorage(stg) -> Ast0.FStorage(storage_mcode stg)
- | Ast0.FType(ty) -> Ast0.FType(typeC ty)
- | Ast0.FInline(inline) -> Ast0.FInline(string_mcode inline)
- | Ast0.FAttr(init) -> Ast0.FAttr(string_mcode init)
-
- and whencode notfn alwaysfn = function
- Ast0.WhenNot a -> Ast0.WhenNot (notfn a)
- | Ast0.WhenAlways a -> Ast0.WhenAlways (alwaysfn a)
- | Ast0.WhenModifier(x) -> Ast0.WhenModifier(x)
- | Ast0.WhenNotTrue(e) -> Ast0.WhenNotTrue(expression e)
- | Ast0.WhenNotFalse(e) -> Ast0.WhenNotFalse(expression e)
-
- and case_line c =
- let k c =
- Ast0.rewrap c
- (match Ast0.unwrap c with
- Ast0.Default(def,colon,code) ->
- Ast0.Default(string_mcode def,string_mcode colon,
- statement_dots code)
- | Ast0.Case(case,exp,colon,code) ->
- Ast0.Case(string_mcode case,expression exp,string_mcode colon,
- statement_dots code)
- | Ast0.OptCase(case) -> Ast0.OptCase(case_line case)) in
- casefn all_functions k c
-
- and top_level t =
- let k t =
- Ast0.rewrap t
- (match Ast0.unwrap t with
- Ast0.FILEINFO(old_file,new_file) ->
- Ast0.FILEINFO(string_mcode old_file, string_mcode new_file)
- | Ast0.DECL(statement_dots) ->
- Ast0.DECL(statement statement_dots)
- | Ast0.CODE(stmt_dots) -> Ast0.CODE(statement_dots stmt_dots)
- | Ast0.ERRORWORDS(exps) -> Ast0.ERRORWORDS(List.map expression exps)
- | Ast0.OTHER(_) -> failwith "unexpected code") in
- topfn all_functions k t
-
- and anything a = (* for compile_iso, not parameterisable *)
- let k = function
- Ast0.DotsExprTag(exprs) -> Ast0.DotsExprTag(expression_dots exprs)
- | Ast0.DotsInitTag(inits) -> Ast0.DotsInitTag(initialiser_list inits)
- | Ast0.DotsParamTag(params) -> Ast0.DotsParamTag(parameter_list params)
- | Ast0.DotsStmtTag(stmts) -> Ast0.DotsStmtTag(statement_dots stmts)
- | Ast0.DotsDeclTag(decls) -> Ast0.DotsDeclTag(declaration_dots decls)
- | Ast0.DotsCaseTag(cases) -> Ast0.DotsCaseTag(case_line_dots cases)
- | Ast0.IdentTag(id) -> Ast0.IdentTag(ident id)
- | Ast0.ExprTag(exp) -> Ast0.ExprTag(expression exp)
- | Ast0.ArgExprTag(exp) -> Ast0.ArgExprTag(expression exp)
- | Ast0.TestExprTag(exp) -> Ast0.TestExprTag(expression exp)
- | Ast0.TypeCTag(ty) -> Ast0.TypeCTag(typeC ty)
- | Ast0.ParamTag(param) -> Ast0.ParamTag(parameterTypeDef param)
- | Ast0.InitTag(init) -> Ast0.InitTag(initialiser init)
- | Ast0.DeclTag(decl) -> Ast0.DeclTag(declaration decl)
- | Ast0.StmtTag(stmt) -> Ast0.StmtTag(statement stmt)
- | Ast0.CaseLineTag(c) -> Ast0.CaseLineTag(case_line c)
- | Ast0.TopTag(top) -> Ast0.TopTag(top_level top)
- | Ast0.IsoWhenTag(x) -> Ast0.IsoWhenTag(x)
- | Ast0.IsoWhenTTag(e) -> Ast0.IsoWhenTTag(expression e)
- | Ast0.IsoWhenFTag(e) -> Ast0.IsoWhenFTag(expression e)
- | Ast0.MetaPosTag(var) -> failwith "not supported" in
- k a
-
- (* not done for combiner, because the statement is assumed to be already
- represented elsewhere in the code *)
-
- and all_functions =
- {rebuilder_ident = ident;
- rebuilder_expression = expression;
- rebuilder_typeC = typeC;
- rebuilder_declaration = declaration;
- rebuilder_initialiser = initialiser;
- rebuilder_initialiser_list = initialiser_list;
- rebuilder_parameter = parameterTypeDef;
- rebuilder_parameter_list = parameter_list;
- rebuilder_statement = statement;
- rebuilder_case_line = case_line;
- rebuilder_top_level = top_level;
- rebuilder_expression_dots = expression_dots;
- rebuilder_statement_dots = statement_dots;
- rebuilder_declaration_dots = declaration_dots;
- rebuilder_case_line_dots = case_line_dots;
- rebuilder_anything = anything} in
- all_functions
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#note: if you add a file (a .mli or .ml), dont forget to do a make depend
-
-TARGET = popl
-
-SRC = ast_popl.ml asttopopl.ml insert_quantifiers.ml insert_befaft.ml \
-pretty_print_popl.ml popltoctl.ml popl.ml flag_popl.ml
-
-SYSLIBS=str.cma unix.cma
-LIBS=../commons/commons.cma ../globals/globals.cma
-
-INCLUDE_PATH = -I ../commons -I ../globals \
- -I ../ctl -I ../parsing_c -I ../parsing_cocci -I ../engine
-
-#The Caml compilers.
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-CAMLC =ocamlc$(OPTBIN) -dtypes -g
-CAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS)
-CAMLLEX = ocamllex$(OPTBIN)
-CAMLYACC= ocamlyacc
-CAMLDEP = ocamldep$(OPTBIN)
-CAMLMKTOP=ocamlmktop -g -custom
-
-
-
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-all: $(LIB)
-all.opt: $(OPTLIB)
-
-$(TARGET).top: $(LIB)
- $(CAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
-
-$(LIB): $(OBJS)
- $(CAMLC) -a -o $(LIB) $(OBJS)
-
-clean::
- rm -f $(LIB) $(TARGET).top
-
-
-$(OPTLIB): $(OPTOBJS)
- $(CAMLOPT) -a -o $(OPTLIB) $(OPTOBJS)
-
-# clean rule for LIB.opt
-clean::
- rm -f $(OPTLIB) $(LIB:.cma=.a)
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(CAMLC) $(INCLUDE_PATH) -c $<
-
-.mli.cmi:
- $(CAMLC) $(INCLUDE_PATH) -c $<
-
-.ml.cmx:
- $(CAMLOPT) $(INCLUDE_PATH) -c $<
-
-
-
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend:
- $(CAMLDEP) $(INCLUDE_PATH) *.mli *.ml > .depend
-
-#clean::
-# rm -f .depend
-
-.depend:
- $(CAMLDEP) $(INCLUDE_PATH) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#note: if you add a file (a .mli or .ml), dont forget to do a make depend
-
-TARGET = popl
-
-SRC = ast_popl.ml asttopopl.ml insert_quantifiers.ml \
-pretty_print_popl.ml flag_popl.ml popltoctl.ml popl.ml
-
-SYSLIBS=str.cma unix.cma
-LIBS=../commons/commons.cma ../globals/globals.cma
-
-INCLUDES = -I ../commons -I ../globals \
- -I ../ctl -I ../parsing_cocci -I ../parsing_c -I ../engine
-
-#The Caml compilers.
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLDEP = ocamldep$(OPTBIN) #$(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom
-
-
-
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-all: $(LIB)
-all.opt: $(OPTLIB)
-
-$(TARGET).top: $(LIB)
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
-
-$(LIB): $(OBJS)
- $(OCAMLC) -a -o $(LIB) $(OBJS)
-
-clean::
- rm -f $(LIB) $(TARGET).top
-
-
-$(OPTLIB): $(OPTOBJS)
- $(OCAMLOPT) -a -o $(OPTLIB) $(OPTOBJS)
-
-# clean rule for LIB.opt
-clean::
- rm -f $(OPTLIB) $(LIB:.cma=.a)
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-
-
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
-#clean::
-# rm -f .depend
-
-.depend:
- $(OCAMLDEP) $(INCLUDE_PATH) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#note: if you add a file (a .mli or .ml), dont forget to do a make depend
-
-TARGET = popl
-
-SRC = ast_popl.ml asttopopl.ml insert_quantifiers.ml \
-pretty_print_popl.ml flag_popl.ml popltoctl.ml popl.ml
-
-SYSLIBS=str.cma unix.cma
-LIBS=../commons/commons.cma ../globals/globals.cma
-
-INCLUDES = -I ../commons -I ../globals \
- -I ../ctl -I ../parsing_cocci -I ../parsing_c -I ../engine
-
-#The Caml compilers.
-#for warning: -w A
-#for profiling: -p -inline 0 with OCAMLOPT
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLDEP = ocamldep$(OPTBIN) $(INCLUDES)
-OCAMLMKTOP=ocamlmktop -g -custom
-
-
-
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-OBJS = $(SRC:.ml=.cmo)
-OPTOBJS = $(SRC:.ml=.cmx)
-
-all: $(LIB)
-all.opt: $(OPTLIB)
-
-$(TARGET).top: $(LIB)
- $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
-
-$(LIB): $(OBJS)
- $(OCAMLC) -a -o $(LIB) $(OBJS)
-
-clean::
- rm -f $(LIB) $(TARGET).top
-
-
-$(OPTLIB): $(OPTOBJS)
- $(OCAMLOPT) -a -o $(OPTLIB) $(OPTOBJS)
-
-# clean rule for LIB.opt
-clean::
- rm -f $(OPTLIB) $(LIB:.cma=.a)
-
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-
-
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
-#clean::
-# rm -f .depend
-
-.depend:
- $(OCAMLDEP) $(INCLUDE_PATH) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-# Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-# This file is part of Coccinelle.
-#
-# Coccinelle 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, according to version 2 of the License.
-#
-# Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-#
-# The authors reserve the right to distribute this or future versions of
-# Coccinelle under other licenses.
-
-
-#############################################################################
-# Configuration section
-#############################################################################
--include ../Makefile.config
-
-##############################################################################
-# Variables
-##############################################################################
-TARGET=coccipython
-
-SOURCES= pycocci_aux.ml pycocci.ml
-
-INCLUDEDIRS = ../commons ../commons/ocamlextra ../globals ../pycaml \
- ../parsing_c ../parsing_cocci
-
-SYSLIBS = str.cma unix.cma
-LIBS=../commons/commons.cma ../globals/globals.cma
-
-# ../ctl/ctl.cma \
-# ../parsing_c/c_parser.cma ../parsing_cocci/cocci_parser.cma
-#pycaml/pycaml.cma
-
-
-##############################################################################
-# Generic variables
-##############################################################################
-
-INCLUDES=$(INCLUDEDIRS:%=-I %) $(INCLUDESEXTRA)
-
-##############################################################################
-# Generic ocaml variables
-##############################################################################
-
-# The Caml compilers.
-OCAMLCFLAGS ?= -g -dtypes
-OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
-OCAMLOPT = ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
-OCAMLDEP = ocamldep$(OPTBIN) #$(INCLUDES)
-
-
-##############################################################################
-# Top rules
-##############################################################################
-
-EXEC=$(TARGET).byte
-LIB=$(TARGET).cma
-OPTLIB=$(LIB:.cma=.cmxa)
-
-CTLEXEC=$(CTLTARGET)
-
-OBJS = $(SOURCES:.ml=.cmo)
-OPTOBJS = $(OBJS:.cmo=.cmx)
-
-CTLOBJS = $(CTLSOURCES:.ml=.cmo)
-CTLOPTOBJS = $(CTLOBJS:.cmo=.cmx)
-
-
-#all: $(EXEC) $(LIB)
-all: $(LIB)
-
-all.opt: $(OPTLIB)
-
-ctl: $(CTLEXEC)
-
-
-$(LIB): $(OBJS)
- $(OCAMLC) -a -o $(LIB) $(OBJS)
-
-clean::
- rm -f $(LIB)
-
-
-$(OPTLIB): $(OPTOBJS)
- $(OCAMLOPT) -a -o $(OPTLIB) $(OPTOBJS)
-
-
-$(EXEC): $(OBJS) main.cmo $(LIBS)
- $(OCAMLC) -o $(EXEC) $(SYSLIBS) $(LIBS) $(OBJS) main.cmo
-
-$(CTLEXEC): $(CTLOBJS) $(LIBS)
- $(OCAMLC) -o $(CTLEXEC) $(SYSLIBS) $(LIBS) $(CTLOBJS)
-
-
-clean::
- rm -f $(OPTLIB) $(LIB:.cma=.a)
- rm -f $(TARGET) rm -f $(TARGET).byte
- rm -f $(CTLTARGET)
-
-
-#pycocci.ml: ../pycaml/pycaml.ml ../pycaml/pycaml_ml.c
-#pycocci_aux.ml: ../pycaml/pycaml.ml ../pycaml/pycaml_ml.c
-
-rmlinks:
- rm -f pycocci.ml pycocci_aux.ml
-
-##############################################################################
-# Generic ocaml rules
-##############################################################################
-
-.SUFFIXES:
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-
-.ml.cmo:
- $(OCAMLC) -c $<
-
-.mli.cmi:
- $(OCAMLC) -c $<
-
-.ml.cmx:
- $(OCAMLOPT) -c $<
-
-
-# clean rule for others files
-clean::
- rm -f *.cm[iox] *.o *.annot
- rm -f *~ .*~ #*#
-
-beforedepend:
-
-depend: beforedepend
- $(OCAMLDEP) *.mli *.ml > .depend
-
-.depend:
- $(OCAMLDEP) *.mli *.ml > .depend
-
--include .depend
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Ast_c
-open Common
-
-let rec exprrep expr = match expr with
- Ast_c.Ident s -> s
-| Ast_c.Constant c -> constantrep c
-| Ast_c.FunCall (e,args) -> "TODO: FunCall"
-| Ast_c.CondExpr (e1,e2,e3) -> "TODO: CondExpr"
-| Ast_c.Sequence (e1,e2) -> "TODO: Sequence"
-| Ast_c.Assignment (e1,op,e2) -> "TODO: Assignment"
-| Ast_c.Postfix (e,op) -> "TODO: Postfix"
-| Ast_c.Infix (e,op) -> "TODO: Infix"
-| Ast_c.Unary (e,op) -> "TODO: Unary"
-| Ast_c.Binary (e1,op,e2) -> "TODO: Binary"
-| Ast_c.ArrayAccess (e1,e2) -> "TODO: ArrayAccess"
-| Ast_c.RecordAccess (e1,s) -> "TODO: RecordAccess"
-| Ast_c.RecordPtAccess (e,s) -> "TODO: RecordPtAccess"
-| Ast_c.SizeOfExpr e -> "TODO: SizeOfExpr"
-| Ast_c.SizeOfType t -> "TODO: SizeOfType"
-| Ast_c.Cast (t,e) -> "TODO: Cast"
-| Ast_c.StatementExpr c -> "TODO: StatementExpr"
-| Ast_c.Constructor (t,i) -> "TODO: Constructor"
-| Ast_c.ParenExpr e -> "TODO: ParenExpr"
-and constantrep c = match c with
- Ast_c.String (s,isWchar) -> s
-| Ast_c.MultiString -> "TODO: MultiString"
-| Ast_c.Char (s,isWchar) -> s
-| Ast_c.Int s -> s
-| Ast_c.Float (s,t) -> s
-
-let call_pretty f a =
- let str = ref ([] : string list) in
- let pr_elem info = str := (Ast_c.str_of_info info) :: !str in
- let pr_sp _ = () in
- f pr_elem pr_sp a;
- String.concat " " (List.rev !str)
-
-let stringrep mvb = match mvb with
- Ast_c.MetaIdVal s -> s
-| Ast_c.MetaFuncVal s -> s
-| Ast_c.MetaLocalFuncVal s -> s
-| Ast_c.MetaExprVal ((expr,_),[il]) -> (exprrep expr)
-| Ast_c.MetaExprVal e -> "TODO: <<MetaExprVal>>"
-| Ast_c.MetaExprListVal expr_list -> "TODO: <<exprlist>>"
-| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ
-| Ast_c.MetaStmtVal statement -> "TODO: stmt"
-| Ast_c.MetaParamVal params -> "TODO: <<param>>"
-| Ast_c.MetaParamListVal params -> "TODO: <<paramlist>>"
-| Ast_c.MetaListlenVal n -> string_of_int n
-| Ast_c.MetaPosVal (pos1, pos2) ->
- (* Common.sprintf ("pos(%d,%d)") pos1 pos2 *)
- "TODO: <<posval>>"
-| Ast_c.MetaPosValList positions -> "TODO: <<postvallist>>"
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Ast_c
-open Common
-open Pycaml
-open Pycocci_aux
-module StringMap = Map.Make (String)
-
-exception Pycocciexception
-
-let check_return_value v =
- if v = (pynull ()) then
- (pyerr_print ();
- raise Pycocciexception)
- else ()
-let check_int_return_value v =
- if v = -1 then
- (pyerr_print ();
- raise Pycocciexception)
- else ()
-
-let initialised = ref false
-
-let coccinelle_module = ref (pynone ())
-let cocci_file_name = ref ""
-
-(* dealing with python modules loaded *)
-let module_map = ref (StringMap.add "__main__" (pynone ()) StringMap.empty)
-
-let get_module module_name =
- StringMap.find module_name (!module_map)
-
-let is_module_loaded module_name =
- try
- let _ = get_module module_name in
- true
- with Not_found -> false
-
-let load_module module_name =
- if not (is_module_loaded module_name) then
- let m = pyimport_importmodule module_name in
- check_return_value m;
- (module_map := (StringMap.add module_name m (!module_map));
- m)
- else get_module module_name
-(* end python module handling part *)
-
-(* initialisation routines *)
-let pycocci_init () =
- (* initialize *)
- if not !initialised then (
- initialised := true;
- Unix.putenv "PYTHONPATH"
- (Printf.sprintf "%s/coccinelle" (Unix.getenv "HOME"));
- let _ = if not (py_isinitialized () != 0) then
- (if !Flag.show_misc then Common.pr2 "Initializing python\n%!";
- py_initialize()) in
-
- (* set argv *)
- let argv0 = Printf.sprintf "%s%sspatch" (Sys.getcwd ()) (match Sys.os_type with "Win32" -> "\\" | _ -> "/") in
- let _ = pycaml_setargs argv0 in
-
- coccinelle_module := (pymodule_new "coccinelle");
- module_map := StringMap.add "coccinelle" !coccinelle_module !module_map;
- let _ = load_module "coccilib.elems" in
- let _ = load_module "coccilib.output" in
- ()) else
-
- ()
-
-(*let _ = pycocci_init ()*)
-(* end initialisation routines *)
-
-(* python interaction *)
-let split_fqn fqn =
- let last_period = String.rindex fqn '.' in
- let module_name = String.sub fqn 0 last_period in
- let class_name = String.sub fqn (last_period + 1) (String.length fqn - last_period - 1) in
- (module_name, class_name)
-
-let pycocci_get_class_type fqn =
- let (module_name, class_name) = split_fqn fqn in
- let m = get_module module_name in
- let attr = pyobject_getattrstring(m, class_name) in
- check_return_value attr;
- attr
-
-let pycocci_instantiate_class fqn args =
- let class_type = pycocci_get_class_type fqn in
- let obj = pyobject_callobject(class_type, args) in
- check_return_value obj;
- obj
-
-(* end python interaction *)
-
-let inc_match = ref true
-
-let include_match v =
- let truth = pyobject_istrue (pytuple_getitem (v, 1)) in
- check_int_return_value truth;
- inc_match := truth != 0;
- pynone ()
-
-let build_method (mname, camlfunc, args) pymodule classx classdict =
- let cmx = pymethod_new(pywrap_closure camlfunc, args, classx) in
- let v = pydict_setitemstring(classdict, mname, cmx) in
- check_int_return_value v;
- ()
-
-let build_class cname parent methods pymodule =
- let cd = pydict_new() in
- check_return_value cd;
- let cx = pyclass_new(pytuple_fromsingle (pycocci_get_class_type parent), cd, pystring_fromstring cname) in
- check_return_value cx;
- List.iter (function meth -> build_method meth pymodule cx cd) methods;
- let v = pydict_setitemstring(pymodule_getdict pymodule, cname, cx) in
- check_int_return_value v;
- (cd, cx)
-
-let has_environment_binding env name =
- let a = pytuple_toarray name in
- let (rule, name) = (Array.get a 1, Array.get a 2) in
- let orule = pystring_asstring rule in
- let oname = pystring_asstring name in
- let e = List.exists (function (x,y) -> orule = x && oname = y) env in
- if e then pytrue () else pyfalse ()
-
-let pyoutputinstance = ref (pynone ())
-let pyoutputdict = ref (pynone ())
-
-let get_cocci_file args =
- pystring_fromstring (!cocci_file_name)
-
-let build_classes env =
- let _ = pycocci_init () in
- let module_dictionary = pyimport_getmoduledict() in
- coccinelle_module := pymodule_new "coccinelle";
- let mx = !coccinelle_module in
- inc_match := true;
- let (cd, cx) = build_class "Cocci" (!Flag.pyoutput)
- [("include_match", include_match, (pynull()));
- ("has_env_binding", has_environment_binding env, (pynull()))] mx in
- pyoutputinstance := cx;
- pyoutputdict := cd;
- let v1 = pydict_setitemstring(module_dictionary, "coccinelle", mx) in
- check_int_return_value v1;
- let mypystring = pystring_fromstring !cocci_file_name in
- let v2 = pydict_setitemstring(cd, "cocci_file", mypystring) in
- check_int_return_value v2;
- ()
-
-let build_variable name value =
- let mx = !coccinelle_module in
- check_int_return_value (pydict_setitemstring(pymodule_getdict mx, name, value))
-
-let contains_binding e (_,(r,m)) =
- try
- let _ = List.find (function ((re, rm), _) -> r = re && m = rm) e in true
- with Not_found -> false
-
-let construct_variables mv e =
- let find_binding (r,m) =
- try
- let elem = List.find (function ((re,rm),_) -> r = re && m = rm) e in
- Some elem
- with Not_found -> None
- in
-
- let instantiate_Expression(x) =
- let str = pystring_fromstring (Pycocci_aux.exprrep x) in
- pycocci_instantiate_class "coccilib.elems.Expression" (pytuple_fromsingle (str))
- in
-
- let instantiate_Identifier(x) =
- let str = pystring_fromstring x in
- pycocci_instantiate_class "coccilib.elems.Identifier" (pytuple_fromsingle (str))
- in
-
- List.iter (function (py,(r,m)) ->
- match find_binding (r,m) with
- None -> ()
- | Some (_, Ast_c.MetaExprVal ((expr, _), info_list)) ->
- let expr_repr = instantiate_Expression(expr) in
- let _ = build_variable py expr_repr in
- ()
- | Some (_, Ast_c.MetaIdVal id) ->
- let id_repr = instantiate_Identifier(id) in
- let _ = build_variable py id_repr in
- ()
- | Some (_, Ast_c.MetaPosValList l) ->
- let locs =
- List.map
- (function (fname,current_element,(line,col),(line_end,col_end)) ->
- pycocci_instantiate_class "coccilib.elems.Location" (pytuple6
- (pystring_fromstring fname,pystring_fromstring current_element,
- pystring_fromstring (Printf.sprintf "%d" line),
- pystring_fromstring (Printf.sprintf "%d" col),
- pystring_fromstring (Printf.sprintf "%d" line_end),
- pystring_fromstring (Printf.sprintf "%d" col_end)))) l in
- let pylocs = pytuple_fromarray (Array.of_list locs) in
- let _ = build_variable py pylocs in
- ()
- | Some (_,binding) ->
- let _ = build_variable py (pystring_fromstring (Pycocci_aux.stringrep binding))
- in ()
- ) mv;
-
- ()
-
-let set_coccifile cocci_file =
- cocci_file_name := cocci_file;
- ()
-
-
-let pyrun_simplestring s =
- Pycaml.pyrun_simplestring s
-
-let py_isinitialized () =
- Pycaml.py_isinitialized ()
-
-
-let py_finalize () =
- Pycaml.py_finalize ()
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Ast_c
-open Common
-open Pycaml
-
-let rec exprrep expr = match expr with
- Ast_c.Ident s -> s
-| Ast_c.Constant c -> constantrep c
-| Ast_c.FunCall (e,args) -> "TODO: FunCall"
-| Ast_c.CondExpr (e1,e2,e3) -> "TODO: CondExpr"
-| Ast_c.Sequence (e1,e2) -> "TODO: Sequence"
-| Ast_c.Assignment (e1,op,e2) -> "TODO: Assignment"
-| Ast_c.Postfix (e,op) -> "TODO: Postfix"
-| Ast_c.Infix (e,op) -> "TODO: Infix"
-| Ast_c.Unary (e,op) -> "TODO: Unary"
-| Ast_c.Binary (e1,op,e2) -> "TODO: Binary"
-| Ast_c.ArrayAccess (e1,e2) -> "TODO: ArrayAccess"
-| Ast_c.RecordAccess (e1,s) -> "TODO: RecordAccess"
-| Ast_c.RecordPtAccess (e,s) -> "TODO: RecordPtAccess"
-| Ast_c.SizeOfExpr e -> "TODO: SizeOfExpr"
-| Ast_c.SizeOfType t -> "TODO: SizeOfType"
-| Ast_c.Cast (t,e) -> "TODO: Cast"
-| Ast_c.StatementExpr c -> "TODO: StatementExpr"
-| Ast_c.Constructor (t,i) -> "TODO: Constructor"
-| Ast_c.ParenExpr e -> "TODO: ParenExpr"
-and constantrep c = match c with
- Ast_c.String (s,isWchar) -> s
-| Ast_c.MultiString -> "TODO: MultiString"
-| Ast_c.Char (s,isWchar) -> s
-| Ast_c.Int s -> s
-| Ast_c.Float (s,t) -> s
-
-let call_pretty f a =
- let str = ref ([] : string list) in
- let pr_elem info = str := (Ast_c.str_of_info info) :: !str in
- let pr_sp _ = () in
- f pr_elem pr_sp a;
- String.concat " " (List.rev !str)
-
-let stringrep mvb = match mvb with
- Ast_c.MetaIdVal s -> s
-| Ast_c.MetaFuncVal s -> s
-| Ast_c.MetaLocalFuncVal s -> s
-| Ast_c.MetaExprVal ((expr,_),[il]) -> (exprrep expr)
-| Ast_c.MetaExprVal e -> "TODO: <<MetaExprVal>>"
-| Ast_c.MetaExprListVal expr_list -> "TODO: <<exprlist>>"
-| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ
-| Ast_c.MetaStmtVal statement -> "TODO: stmt"
-| Ast_c.MetaParamVal params -> "TODO: <<param>>"
-| Ast_c.MetaParamListVal params -> "TODO: <<paramlist>>"
-| Ast_c.MetaListlenVal n -> string_of_int n
-| Ast_c.MetaPosVal (pos1, pos2) ->
- let print_pos = function
- Ast_cocci.Real x -> string_of_int x
- | Ast_cocci.Virt(x,off) -> Printf.sprintf "%d+%d" x off in
- Common.sprintf ("pos(%s,%s)") (print_pos pos1) (print_pos pos2)
-| Ast_c.MetaPosValList positions -> "TODO: <<postvallist>>"
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Ast_c
-open Common
-open Pycaml
-
-let rec exprrep expr = match expr with
- Ast_c.Ident s -> s
-| Ast_c.Constant c -> constantrep c
-| Ast_c.FunCall (e,args) -> "TODO: FunCall"
-| Ast_c.CondExpr (e1,e2,e3) -> "TODO: CondExpr"
-| Ast_c.Sequence (e1,e2) -> "TODO: Sequence"
-| Ast_c.Assignment (e1,op,e2) -> "TODO: Assignment"
-| Ast_c.Postfix (e,op) -> "TODO: Postfix"
-| Ast_c.Infix (e,op) -> "TODO: Infix"
-| Ast_c.Unary (e,op) -> "TODO: Unary"
-| Ast_c.Binary (e1,op,e2) -> "TODO: Binary"
-| Ast_c.ArrayAccess (e1,e2) -> "TODO: ArrayAccess"
-| Ast_c.RecordAccess (e1,s) -> "TODO: RecordAccess"
-| Ast_c.RecordPtAccess (e,s) -> "TODO: RecordPtAccess"
-| Ast_c.SizeOfExpr e -> "TODO: SizeOfExpr"
-| Ast_c.SizeOfType t -> "TODO: SizeOfType"
-| Ast_c.Cast (t,e) -> "TODO: Cast"
-| Ast_c.StatementExpr c -> "TODO: StatementExpr"
-| Ast_c.Constructor (t,i) -> "TODO: Constructor"
-| Ast_c.ParenExpr e -> "TODO: ParenExpr"
-and constantrep c = match c with
- Ast_c.String (s,isWchar) -> s
-| Ast_c.MultiString -> "TODO: MultiString"
-| Ast_c.Char (s,isWchar) -> s
-| Ast_c.Int s -> s
-| Ast_c.Float (s,t) -> s
-
-let call_pretty f a =
- let str = ref ([] : string list) in
- let pr_elem info = str := (Ast_c.str_of_info info) :: !str in
- let pr_sp _ = () in
- f pr_elem pr_sp a;
- String.concat " " (List.rev !str)
-
-let stringrep mvb = match mvb with
- Ast_c.MetaIdVal s -> s
-| Ast_c.MetaFuncVal s -> s
-| Ast_c.MetaLocalFuncVal s -> s
-| Ast_c.MetaExprVal ((expr,_),[il]) -> (exprrep expr)
-| Ast_c.MetaExprVal e -> "TODO: <<MetaExprVal>>"
-| Ast_c.MetaExprListVal expr_list -> "TODO: <<exprlist>>"
-| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ
-| Ast_c.MetaInitVal ini -> "TODO: <<initiliser>>"
-| Ast_c.MetaStmtVal statement -> "TODO: stmt"
-| Ast_c.MetaParamVal params -> "TODO: <<param>>"
-| Ast_c.MetaParamListVal params -> "TODO: <<paramlist>>"
-| Ast_c.MetaListlenVal n -> string_of_int n
-| Ast_c.MetaPosVal (pos1, pos2) ->
- let print_pos = function
- Ast_cocci.Real x -> string_of_int x
- | Ast_cocci.Virt(x,off) -> Printf.sprintf "%d+%d" x off in
- Common.sprintf ("pos(%s,%s)") (print_pos pos1) (print_pos pos2)
-| Ast_c.MetaPosValList positions -> "TODO: <<postvallist>>"
-
+++ /dev/null
-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* This file is part of Coccinelle.
-*
-* Coccinelle 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, according to version 2 of the License.
-*
-* Coccinelle is distributed in the hope that 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 Coccinelle. If not, see <http://www.gnu.org/licenses/>.
-*
-* The authors reserve the right to distribute this or future versions of
-* Coccinelle under other licenses.
-*)
-
-
-open Ast_c
-open Common
-open Pycaml
-
-let rec exprrep expr = match expr with
- Ast_c.Ident s -> s
-| Ast_c.Constant c -> constantrep c
-| Ast_c.FunCall (e,args) -> "TODO: FunCall"
-| Ast_c.CondExpr (e1,e2,e3) -> "TODO: CondExpr"
-| Ast_c.Sequence (e1,e2) -> "TODO: Sequence"
-| Ast_c.Assignment (e1,op,e2) -> "TODO: Assignment"
-| Ast_c.Postfix (e,op) -> "TODO: Postfix"
-| Ast_c.Infix (e,op) -> "TODO: Infix"
-| Ast_c.Unary (e,op) -> "TODO: Unary"
-| Ast_c.Binary (e1,op,e2) -> "TODO: Binary"
-| Ast_c.ArrayAccess (e1,e2) -> "TODO: ArrayAccess"
-| Ast_c.RecordAccess (e1,s) -> "TODO: RecordAccess"
-| Ast_c.RecordPtAccess (e,s) -> "TODO: RecordPtAccess"
-| Ast_c.SizeOfExpr e -> "TODO: SizeOfExpr"
-| Ast_c.SizeOfType t -> "TODO: SizeOfType"
-| Ast_c.Cast (t,e) -> "TODO: Cast"
-| Ast_c.StatementExpr c -> "TODO: StatementExpr"
-| Ast_c.Constructor (t,i) -> "TODO: Constructor"
-| Ast_c.ParenExpr e -> "TODO: ParenExpr"
-and constantrep c = match c with
- Ast_c.String (s,isWchar) -> s
-| Ast_c.MultiString sl -> String.concat "" sl
-| Ast_c.Char (s,isWchar) -> s
-| Ast_c.Int s -> s
-| Ast_c.Float (s,t) -> s
-
-let call_pretty f a =
- let str = ref ([] : string list) in
- let pr_elem info = str := (Ast_c.str_of_info info) :: !str in
- let pr_sp _ = () in
- f pr_elem pr_sp a;
- String.concat " " (List.rev !str)
-
-let stringrep mvb = match mvb with
- Ast_c.MetaIdVal s -> s
-| Ast_c.MetaFuncVal s -> s
-| Ast_c.MetaLocalFuncVal s -> s
-| Ast_c.MetaExprVal ((expr,_),[il]) -> (exprrep expr)
-| Ast_c.MetaExprVal e -> "TODO: <<MetaExprVal>>"
-| Ast_c.MetaExprListVal expr_list -> "TODO: <<exprlist>>"
-| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ
-| Ast_c.MetaInitVal ini -> "TODO: <<initiliser>>"
-| Ast_c.MetaStmtVal statement -> "TODO: stmt"
-| Ast_c.MetaParamVal params -> "TODO: <<param>>"
-| Ast_c.MetaParamListVal params -> "TODO: <<paramlist>>"
-| Ast_c.MetaListlenVal n -> string_of_int n
-| Ast_c.MetaPosVal (pos1, pos2) ->
- let print_pos = function
- Ast_cocci.Real x -> string_of_int x
- | Ast_cocci.Virt(x,off) -> Printf.sprintf "%d+%d" x off in
- Common.sprintf ("pos(%s,%s)") (print_pos pos1) (print_pos pos2)
-| Ast_c.MetaPosValList positions -> "TODO: <<postvallist>>"
-
-#!/bin/bash
+#!/bin/sh
DN=`dirname $0`
if [ -z ${PYTHONPATH} ]
-#!/bin/bash
-
-echo setting COCCINELLE_HOME=${COCCINELLE_HOME:=SHAREDIR}
-
-if [ ! -r $COCCINELLE_HOME/standard.iso ] ; then
- echo "There is no standard.iso in SHAREDIR."
- echo "Are you sure you run a properly installed version of spatch ?\n"
-else
-
- export COCCINELLE_HOME
- export LD_LIBRARY_PATH=$COCCINELLE_HOME:$LD_LIBRARY_PATH
- export PYTHONPATH=$COCCINELLE_HOME/python:$PYTHONPATH
-
- echo setting LD_LIBRARY_PATH=$LD_LIBRARY_PATH
- echo setting PYTHONPATH=$PYTHONPATH
-
-fi
-
-$COCCINELLE_HOME/spatch.opt $*
-
+#!/bin/sh
+
+COCCINELLE_HOME=${COCCINELLE_HOME:=SHAREDIR}
+#echo setting COCCINELLE_HOME=${COCCINELLE_HOME:=SHAREDIR}
+
+if [ ! -r "$COCCINELLE_HOME"/standard.iso ] ; then
+ echo "There is no standard.iso in SHAREDIR."
+ echo "Are you sure you run a properly installed version of spatch ?\n"
+else
+
+ export COCCINELLE_HOME
+ export LD_LIBRARY_PATH="$COCCINELLE_HOME:$LD_LIBRARY_PATH"
+ export PYTHONPATH="$COCCINELLE_HOME/python:$PYTHONPATH"
+
+# echo setting LD_LIBRARY_PATH="$LD_LIBRARY_PATH"
+# echo setting PYTHONPATH="$PYTHONPATH"
+
+fi
+
+"$COCCINELLE_HOME"/spatch.opt "$@"
+
then
begin
let o = open_out (Printf.sprintf "%s/files" !dir) in
- Printf.fprintf o "#!/bin/bash\n\n";
+ Printf.fprintf o "#!/bin/sh\n\n";
sedify o !gen !dir l;
sedify_ors o !gen !dir l;
Printf.fprintf o "\nwait\n/bin/rm tmp*out\n";