From 8ba84ae2b4ba7d58a4c0f6d90ca093c9202ca5ab Mon Sep 17 00:00:00 2001 From: Coccinelle Date: Sun, 3 Oct 2010 13:57:45 +0200 Subject: [PATCH] Release coccinelle-0.1.6a Bugfix. --- .#Makefile.1.117 | 465 -- .#Makefile.1.121 | 461 -- .#Makefile.1.122 | 462 -- .#Makefile.1.123 | 464 -- .#Makefile.1.125 | 467 -- .#Makefile.1.127 | 467 -- .#cocci.ml.1.295 | 1512 ------- .#main.ml.1.242 | 839 ---- .#main.ml.1.248 | 847 ---- .#testing.ml.1.67 | 414 -- Makefile | 37 +- Makefile.config | 22 - commitmsg | 30 +- configure | 48 +- ctl/.#Makefile.1.21 | 95 - ctl/.#Makefile.1.22 | 95 - engine/.#Makefile.1.52 | 126 - engine/.#Makefile.1.53 | 126 - engine/.#Makefile.1.54 | 126 - engine/.#asttoctl.ml.1.81 | 1462 ------- engine/.#asttoctl2.ml.1.152 | 2340 ---------- engine/.#cocci_vs_c.ml.1.26 | 3745 ---------------- engine/.#cocci_vs_c.ml.1.28 | 3765 ----------------- engine/.#cocci_vs_c.ml.1.29 | 3765 ----------------- engine/.#lib_matcher_c.ml.1.1 | 156 - engine/.#pattern_c.ml.1.3 | 494 --- engine/.#pretty_print_engine.ml.1.43 | 161 - engine/.#transformation_c.ml.1.3 | 547 --- globals/config.ml | 2 +- parsing_cocci/.#Makefile.1.50 | 136 - parsing_cocci/.#Makefile.1.51 | 136 - parsing_cocci/.#arity.ml.1.87 | 1070 ----- parsing_cocci/.#arity.ml.1.88 | 1074 ----- parsing_cocci/.#ast0_cocci.ml.1.113 | 670 --- parsing_cocci/.#ast0_cocci.ml.1.115 | 672 --- parsing_cocci/.#ast0toast.ml.1.139 | 934 ---- parsing_cocci/.#ast0toast.ml.1.140 | 938 ---- parsing_cocci/.#ast_cocci.ml.1.149 | 678 --- parsing_cocci/.#ast_cocci.ml.1.151 | 682 --- parsing_cocci/.#check_meta.ml.1.86 | 535 --- parsing_cocci/.#check_meta.ml.1.88 | 539 --- parsing_cocci/.#compute_lines.ml.1.90 | 769 ---- parsing_cocci/.#compute_lines.ml.1.92 | 771 ---- parsing_cocci/.#context_neg.ml.1.103 | 1013 ----- parsing_cocci/.#context_neg.ml.1.104 | 1023 ----- parsing_cocci/.#data.ml.1.37 | 148 - parsing_cocci/.#data.ml.1.38 | 151 - parsing_cocci/.#disjdistr.ml.1.27 | 395 -- parsing_cocci/.#free_vars.ml.1.83 | 787 ---- parsing_cocci/.#index.ml.1.59 | 222 - parsing_cocci/.#index.ml.1.60 | 221 - parsing_cocci/.#insert_plus.ml.1.74 | 952 ----- parsing_cocci/.#iso_pattern.ml.1.150 | 2342 ---------- parsing_cocci/.#iso_pattern.ml.1.152 | 2379 ----------- parsing_cocci/.#lexer_cocci.mll.1.84 | 704 --- parsing_cocci/.#lexer_cocci.mll.1.86 | 712 ---- parsing_cocci/.#parse_aux.ml.1.26 | 475 --- parsing_cocci/.#parse_aux.ml.1.27 | 482 --- parsing_cocci/.#parse_cocci.ml.1.178 | 1598 ------- parsing_cocci/.#parse_cocci.ml.1.180 | 1628 ------- parsing_cocci/.#parser_cocci_menhir.mly.1.166 | 1847 -------- parsing_cocci/.#parser_cocci_menhir.mly.1.168 | 1859 -------- parsing_cocci/.#parser_cocci_menhir.mly.1.169 | 1859 -------- parsing_cocci/.#pretty_print_cocci.ml.1.134 | 864 ---- parsing_cocci/.#pretty_print_cocci.ml.1.135 | 865 ---- parsing_cocci/.#type_infer.ml.1.60 | 384 -- parsing_cocci/.#unify_ast.ml.1.75 | 574 --- parsing_cocci/.#unparse_ast0.ml.1.116 | 667 --- parsing_cocci/.#unparse_ast0.ml.1.118 | 667 --- parsing_cocci/.#visitor_ast.ml.1.95 | 1056 ----- parsing_cocci/.#visitor_ast.ml.1.97 | 1061 ----- parsing_cocci/.#visitor_ast0.ml.1.87 | 1041 ----- popl/.#Makefile.1.5 | 102 - popl09/.#Makefile.1.5 | 101 - popl09/.#Makefile.1.6 | 101 - python/.#Makefile.1.5 | 146 - python/.#no_pycocci_aux.ml.1.2 | 76 - python/.#yes_pycocci.ml.1.2 | 243 -- python/.#yes_pycocci_aux.ml.1.1 | 79 - python/.#yes_pycocci_aux.ml.1.2 | 80 - python/.#yes_pycocci_aux.ml.1.3 | 80 - runspatch.opt | 2 +- scripts/spatch.sh | 41 +- tools/alloc_free.ml | 2 +- 84 files changed, 94 insertions(+), 62079 deletions(-) delete mode 100644 .#Makefile.1.117 delete mode 100644 .#Makefile.1.121 delete mode 100644 .#Makefile.1.122 delete mode 100644 .#Makefile.1.123 delete mode 100644 .#Makefile.1.125 delete mode 100644 .#Makefile.1.127 delete mode 100644 .#cocci.ml.1.295 delete mode 100644 .#main.ml.1.242 delete mode 100644 .#main.ml.1.248 delete mode 100644 .#testing.ml.1.67 delete mode 100644 Makefile.config rewrite commitmsg (99%) delete mode 100644 ctl/.#Makefile.1.21 delete mode 100644 ctl/.#Makefile.1.22 delete mode 100644 engine/.#Makefile.1.52 delete mode 100644 engine/.#Makefile.1.53 delete mode 100644 engine/.#Makefile.1.54 delete mode 100644 engine/.#asttoctl.ml.1.81 delete mode 100644 engine/.#asttoctl2.ml.1.152 delete mode 100644 engine/.#cocci_vs_c.ml.1.26 delete mode 100644 engine/.#cocci_vs_c.ml.1.28 delete mode 100644 engine/.#cocci_vs_c.ml.1.29 delete mode 100644 engine/.#lib_matcher_c.ml.1.1 delete mode 100644 engine/.#pattern_c.ml.1.3 delete mode 100644 engine/.#pretty_print_engine.ml.1.43 delete mode 100644 engine/.#transformation_c.ml.1.3 delete mode 100644 parsing_cocci/.#Makefile.1.50 delete mode 100644 parsing_cocci/.#Makefile.1.51 delete mode 100644 parsing_cocci/.#arity.ml.1.87 delete mode 100644 parsing_cocci/.#arity.ml.1.88 delete mode 100644 parsing_cocci/.#ast0_cocci.ml.1.113 delete mode 100644 parsing_cocci/.#ast0_cocci.ml.1.115 delete mode 100644 parsing_cocci/.#ast0toast.ml.1.139 delete mode 100644 parsing_cocci/.#ast0toast.ml.1.140 delete mode 100644 parsing_cocci/.#ast_cocci.ml.1.149 delete mode 100644 parsing_cocci/.#ast_cocci.ml.1.151 delete mode 100644 parsing_cocci/.#check_meta.ml.1.86 delete mode 100644 parsing_cocci/.#check_meta.ml.1.88 delete mode 100644 parsing_cocci/.#compute_lines.ml.1.90 delete mode 100644 parsing_cocci/.#compute_lines.ml.1.92 delete mode 100644 parsing_cocci/.#context_neg.ml.1.103 delete mode 100644 parsing_cocci/.#context_neg.ml.1.104 delete mode 100644 parsing_cocci/.#data.ml.1.37 delete mode 100644 parsing_cocci/.#data.ml.1.38 delete mode 100644 parsing_cocci/.#disjdistr.ml.1.27 delete mode 100644 parsing_cocci/.#free_vars.ml.1.83 delete mode 100644 parsing_cocci/.#index.ml.1.59 delete mode 100644 parsing_cocci/.#index.ml.1.60 delete mode 100644 parsing_cocci/.#insert_plus.ml.1.74 delete mode 100644 parsing_cocci/.#iso_pattern.ml.1.150 delete mode 100644 parsing_cocci/.#iso_pattern.ml.1.152 delete mode 100644 parsing_cocci/.#lexer_cocci.mll.1.84 delete mode 100644 parsing_cocci/.#lexer_cocci.mll.1.86 delete mode 100644 parsing_cocci/.#parse_aux.ml.1.26 delete mode 100644 parsing_cocci/.#parse_aux.ml.1.27 delete mode 100644 parsing_cocci/.#parse_cocci.ml.1.178 delete mode 100644 parsing_cocci/.#parse_cocci.ml.1.180 delete mode 100644 parsing_cocci/.#parser_cocci_menhir.mly.1.166 delete mode 100644 parsing_cocci/.#parser_cocci_menhir.mly.1.168 delete mode 100644 parsing_cocci/.#parser_cocci_menhir.mly.1.169 delete mode 100644 parsing_cocci/.#pretty_print_cocci.ml.1.134 delete mode 100644 parsing_cocci/.#pretty_print_cocci.ml.1.135 delete mode 100644 parsing_cocci/.#type_infer.ml.1.60 delete mode 100644 parsing_cocci/.#unify_ast.ml.1.75 delete mode 100644 parsing_cocci/.#unparse_ast0.ml.1.116 delete mode 100644 parsing_cocci/.#unparse_ast0.ml.1.118 delete mode 100644 parsing_cocci/.#visitor_ast.ml.1.95 delete mode 100644 parsing_cocci/.#visitor_ast.ml.1.97 delete mode 100644 parsing_cocci/.#visitor_ast0.ml.1.87 delete mode 100644 popl/.#Makefile.1.5 delete mode 100644 popl09/.#Makefile.1.5 delete mode 100644 popl09/.#Makefile.1.6 delete mode 100644 python/.#Makefile.1.5 delete mode 100644 python/.#no_pycocci_aux.ml.1.2 delete mode 100644 python/.#yes_pycocci.ml.1.2 delete mode 100644 python/.#yes_pycocci_aux.ml.1.1 delete mode 100644 python/.#yes_pycocci_aux.ml.1.2 delete mode 100644 python/.#yes_pycocci_aux.ml.1.3 rewrite scripts/spatch.sh (67%) diff --git a/.#Makefile.1.117 b/.#Makefile.1.117 deleted file mode 100644 index 6e50fe9..0000000 --- a/.#Makefile.1.117 +++ /dev/null @@ -1,465 +0,0 @@ -# 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 . -# -# 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 diff --git a/.#Makefile.1.121 b/.#Makefile.1.121 deleted file mode 100644 index c20c3cf..0000000 --- a/.#Makefile.1.121 +++ /dev/null @@ -1,461 +0,0 @@ -# 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 . -# -# 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 diff --git a/.#Makefile.1.122 b/.#Makefile.1.122 deleted file mode 100644 index 1168f58..0000000 --- a/.#Makefile.1.122 +++ /dev/null @@ -1,462 +0,0 @@ -# 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 . -# -# 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 diff --git a/.#Makefile.1.123 b/.#Makefile.1.123 deleted file mode 100644 index dcef57f..0000000 --- a/.#Makefile.1.123 +++ /dev/null @@ -1,464 +0,0 @@ -# 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 . -# -# 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 diff --git a/.#Makefile.1.125 b/.#Makefile.1.125 deleted file mode 100644 index 6909149..0000000 --- a/.#Makefile.1.125 +++ /dev/null @@ -1,467 +0,0 @@ -# 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 . -# -# 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 diff --git a/.#Makefile.1.127 b/.#Makefile.1.127 deleted file mode 100644 index 59a8518..0000000 --- a/.#Makefile.1.127 +++ /dev/null @@ -1,467 +0,0 @@ -# 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 . -# -# 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 diff --git a/.#cocci.ml.1.295 b/.#cocci.ml.1.295 deleted file mode 100644 index 1c1c45a..0000000 --- a/.#cocci.ml.1.295 +++ /dev/null @@ -1,1512 +0,0 @@ -(* -* 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 . -* -* 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 - *) - -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) - diff --git a/.#main.ml.1.242 b/.#main.ml.1.242 deleted file mode 100644 index 393cc31..0000000 --- a/.#main.ml.1.242 +++ /dev/null @@ -1,839 +0,0 @@ -(* -* 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 . -* -* 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 [-o ] [-iso_file ] [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, - " the semantic patch file"; - - "-o", Arg.Set_string output_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, - " (default=" ^ !Config.std_iso ^")"; - "-macro_file", Arg.Set_string Config.std_h, - " (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, - " containing the Linux headers (optional)"; - - - "-dir", Arg.Set 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), - (" 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, - " improve -dir by grouping related c files"; - "-pyoutput", Arg.Set_string Flag.pyoutput, - " Sets output routine: Standard values: "; - - - "-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, - " 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), - " for profiling the CTL engine"; - "-timeout", Arg.Int (fun x -> FC.timeout := Some x), - " 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, - " 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), - " "); - (let s = "-compare_c" in s, Arg.Unit (fun () -> action := s), - " "); - ]); -] - - -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 "; - - 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(); - ) diff --git a/.#main.ml.1.248 b/.#main.ml.1.248 deleted file mode 100644 index 992b6ae..0000000 --- a/.#main.ml.1.248 +++ /dev/null @@ -1,847 +0,0 @@ -(* -* 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 . -* -* 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 [-o ] [-iso_file ] [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, - " the semantic patch file"; - - "-o", Arg.Set_string output_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, - " (default=" ^ !Config.std_iso ^")"; - "-macro_file", Arg.Set_string Config.std_h, - " (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, - " containing the Linux headers (optional)"; - - - "-dir", Arg.Set 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), - (" 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, - " improve -dir by grouping related c files"; - "-pyoutput", Arg.Set_string Flag.pyoutput, - " Sets output routine: Standard values: "; - - - "-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, - " 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), - " for profiling the CTL engine"; - "-timeout", Arg.Int (fun x -> FC.timeout := Some x), - " 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, - " 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), - " "); - (let s = "-compare_c" in s, Arg.Unit (fun () -> action := s), - " "); - ]); -] - - -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 "; - - 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(); - ) diff --git a/.#testing.ml.1.67 b/.#testing.ml.1.67 deleted file mode 100644 index c1087eb..0000000 --- a/.#testing.ml.1.67 +++ /dev/null @@ -1,414 +0,0 @@ -(* -* 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 . -* -* 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.*\"") "" 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) -*) - diff --git a/Makefile b/Makefile index fd8a9c5..f516238 100644 --- a/Makefile +++ b/Makefile @@ -202,40 +202,51 @@ purebytecode: ############################################################################## # 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 @@ -305,7 +316,7 @@ 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)/$(PACKAGE); rm -f todo_pos cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude-vcs $(PACKAGE) rm -rf $(TMP)/$(PACKAGE) diff --git a/Makefile.config b/Makefile.config deleted file mode 100644 index dd601ee..0000000 --- a/Makefile.config +++ /dev/null @@ -1,22 +0,0 @@ -# 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 diff --git a/commitmsg b/commitmsg dissimilarity index 99% index 6f7c7cc..a1ea097 100644 --- a/commitmsg +++ b/commitmsg @@ -1,27 +1,3 @@ -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 for the bug report. +Release coccinelle-0.1.6a + +Bugfix. diff --git a/configure b/configure index bd012c0..17533b9 100755 --- a/configure +++ b/configure @@ -29,12 +29,13 @@ my $opt=".opt"; 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; @@ -98,13 +99,45 @@ $error += ); 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."; } } @@ -210,6 +243,11 @@ pr2 "Generating Makefile.config"; 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 diff --git a/ctl/.#Makefile.1.21 b/ctl/.#Makefile.1.21 deleted file mode 100644 index 8785901..0000000 --- a/ctl/.#Makefile.1.21 +++ /dev/null @@ -1,95 +0,0 @@ -# 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 . -# -# 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 diff --git a/ctl/.#Makefile.1.22 b/ctl/.#Makefile.1.22 deleted file mode 100644 index 253b8cf..0000000 --- a/ctl/.#Makefile.1.22 +++ /dev/null @@ -1,95 +0,0 @@ -# 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 . -# -# 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 diff --git a/engine/.#Makefile.1.52 b/engine/.#Makefile.1.52 deleted file mode 100644 index c989683..0000000 --- a/engine/.#Makefile.1.52 +++ /dev/null @@ -1,126 +0,0 @@ -# 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 . -# -# 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 diff --git a/engine/.#Makefile.1.53 b/engine/.#Makefile.1.53 deleted file mode 100644 index b4f53ac..0000000 --- a/engine/.#Makefile.1.53 +++ /dev/null @@ -1,126 +0,0 @@ -# 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 . -# -# 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 diff --git a/engine/.#Makefile.1.54 b/engine/.#Makefile.1.54 deleted file mode 100644 index 25f7684..0000000 --- a/engine/.#Makefile.1.54 +++ /dev/null @@ -1,126 +0,0 @@ -# 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 . -# -# 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 diff --git a/engine/.#asttoctl.ml.1.81 b/engine/.#asttoctl.ml.1.81 deleted file mode 100644 index a569a97..0000000 --- a/engine/.#asttoctl.ml.1.81 +++ /dev/null @@ -1,1462 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/engine/.#asttoctl2.ml.1.152 b/engine/.#asttoctl2.ml.1.152 deleted file mode 100644 index 865a633..0000000 --- a/engine/.#asttoctl2.ml.1.152 +++ /dev/null @@ -1,2340 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/engine/.#cocci_vs_c.ml.1.26 b/engine/.#cocci_vs_c.ml.1.26 deleted file mode 100644 index 181e174..0000000 --- a/engine/.#cocci_vs_c.ml.1.26 +++ /dev/null @@ -1,3745 +0,0 @@ -(* -* 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 . -* -* 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 in the .cocci, need to find where is - * the '+' attached to this element, to later find the first concrete - * #include 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 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 - diff --git a/engine/.#cocci_vs_c.ml.1.28 b/engine/.#cocci_vs_c.ml.1.28 deleted file mode 100644 index 4b4bee4..0000000 --- a/engine/.#cocci_vs_c.ml.1.28 +++ /dev/null @@ -1,3765 +0,0 @@ -(* -* 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 . -* -* 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 in the .cocci, need to find where is - * the '+' attached to this element, to later find the first concrete - * #include 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 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 - diff --git a/engine/.#cocci_vs_c.ml.1.29 b/engine/.#cocci_vs_c.ml.1.29 deleted file mode 100644 index 75ddf8e..0000000 --- a/engine/.#cocci_vs_c.ml.1.29 +++ /dev/null @@ -1,3765 +0,0 @@ -(* -* 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 . -* -* 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 in the .cocci, need to find where is - * the '+' attached to this element, to later find the first concrete - * #include 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 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 - diff --git a/engine/.#lib_matcher_c.ml.1.1 b/engine/.#lib_matcher_c.ml.1.1 deleted file mode 100644 index 87b0a72..0000000 --- a/engine/.#lib_matcher_c.ml.1.1 +++ /dev/null @@ -1,156 +0,0 @@ -(* -* 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 . -* -* 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"; - ) - - - - diff --git a/engine/.#pattern_c.ml.1.3 b/engine/.#pattern_c.ml.1.3 deleted file mode 100644 index 142893f..0000000 --- a/engine/.#pattern_c.ml.1.3 +++ /dev/null @@ -1,494 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/engine/.#pretty_print_engine.ml.1.43 b/engine/.#pretty_print_engine.ml.1.43 deleted file mode 100644 index 03fafd2..0000000 --- a/engine/.#pretty_print_engine.ml.1.43 +++ /dev/null @@ -1,161 +0,0 @@ -(* -* 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 . -* -* 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 "<>" - | 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 "<>" - | Ast_c.MetaParamListVal params -> pp "<>" - | 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 " - | 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 - - diff --git a/engine/.#transformation_c.ml.1.3 b/engine/.#transformation_c.ml.1.3 deleted file mode 100644 index 8dc3f98..0000000 --- a/engine/.#transformation_c.ml.1.3 +++ /dev/null @@ -1,547 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/globals/config.ml b/globals/config.ml index cf9f4a3..c133614 100644 --- a/globals/config.ml +++ b/globals/config.ml @@ -1,4 +1,4 @@ -let version = "0.1.6" +let version = "0.1.6a" let path = try (Sys.getenv "COCCINELLE_HOME") diff --git a/parsing_cocci/.#Makefile.1.50 b/parsing_cocci/.#Makefile.1.50 deleted file mode 100644 index f710d1e..0000000 --- a/parsing_cocci/.#Makefile.1.50 +++ /dev/null @@ -1,136 +0,0 @@ -# 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 . -# -# 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 diff --git a/parsing_cocci/.#Makefile.1.51 b/parsing_cocci/.#Makefile.1.51 deleted file mode 100644 index 4028a45..0000000 --- a/parsing_cocci/.#Makefile.1.51 +++ /dev/null @@ -1,136 +0,0 @@ -# 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 . -# -# 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 diff --git a/parsing_cocci/.#arity.ml.1.87 b/parsing_cocci/.#arity.ml.1.87 deleted file mode 100644 index 3fb1665..0000000 --- a/parsing_cocci/.#arity.ml.1.87 +++ /dev/null @@ -1,1070 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#arity.ml.1.88 b/parsing_cocci/.#arity.ml.1.88 deleted file mode 100644 index 56213c8..0000000 --- a/parsing_cocci/.#arity.ml.1.88 +++ /dev/null @@ -1,1074 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#ast0_cocci.ml.1.113 b/parsing_cocci/.#ast0_cocci.ml.1.113 deleted file mode 100644 index b40bb6e..0000000 --- a/parsing_cocci/.#ast0_cocci.ml.1.113 +++ /dev/null @@ -1,670 +0,0 @@ -(* -* 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 . -* -* 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 *) diff --git a/parsing_cocci/.#ast0_cocci.ml.1.115 b/parsing_cocci/.#ast0_cocci.ml.1.115 deleted file mode 100644 index fe3ba6a..0000000 --- a/parsing_cocci/.#ast0_cocci.ml.1.115 +++ /dev/null @@ -1,672 +0,0 @@ -(* -* 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 . -* -* 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 *) diff --git a/parsing_cocci/.#ast0toast.ml.1.139 b/parsing_cocci/.#ast0toast.ml.1.139 deleted file mode 100644 index 91da782..0000000 --- a/parsing_cocci/.#ast0toast.ml.1.139 +++ /dev/null @@ -1,934 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#ast0toast.ml.1.140 b/parsing_cocci/.#ast0toast.ml.1.140 deleted file mode 100644 index 274f7f9..0000000 --- a/parsing_cocci/.#ast0toast.ml.1.140 +++ /dev/null @@ -1,938 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#ast_cocci.ml.1.149 b/parsing_cocci/.#ast_cocci.ml.1.149 deleted file mode 100644 index 4521d24..0000000 --- a/parsing_cocci/.#ast_cocci.ml.1.149 +++ /dev/null @@ -1,678 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#ast_cocci.ml.1.151 b/parsing_cocci/.#ast_cocci.ml.1.151 deleted file mode 100644 index ee0a43a..0000000 --- a/parsing_cocci/.#ast_cocci.ml.1.151 +++ /dev/null @@ -1,682 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#check_meta.ml.1.86 b/parsing_cocci/.#check_meta.ml.1.86 deleted file mode 100644 index 9c8fcd2..0000000 --- a/parsing_cocci/.#check_meta.ml.1.86 +++ /dev/null @@ -1,535 +0,0 @@ -(* -* 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 . -* -* 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 "" diff --git a/parsing_cocci/.#check_meta.ml.1.88 b/parsing_cocci/.#check_meta.ml.1.88 deleted file mode 100644 index ff7d88e..0000000 --- a/parsing_cocci/.#check_meta.ml.1.88 +++ /dev/null @@ -1,539 +0,0 @@ -(* -* 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 . -* -* 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 "" diff --git a/parsing_cocci/.#compute_lines.ml.1.90 b/parsing_cocci/.#compute_lines.ml.1.90 deleted file mode 100644 index 67ec35d..0000000 --- a/parsing_cocci/.#compute_lines.ml.1.90 +++ /dev/null @@ -1,769 +0,0 @@ -(* -* 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 . -* -* 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 - diff --git a/parsing_cocci/.#compute_lines.ml.1.92 b/parsing_cocci/.#compute_lines.ml.1.92 deleted file mode 100644 index d93ed9e..0000000 --- a/parsing_cocci/.#compute_lines.ml.1.92 +++ /dev/null @@ -1,771 +0,0 @@ -(* -* 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 . -* -* 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 - diff --git a/parsing_cocci/.#context_neg.ml.1.103 b/parsing_cocci/.#context_neg.ml.1.103 deleted file mode 100644 index 84eaabe..0000000 --- a/parsing_cocci/.#context_neg.ml.1.103 +++ /dev/null @@ -1,1013 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#context_neg.ml.1.104 b/parsing_cocci/.#context_neg.ml.1.104 deleted file mode 100644 index 67b3317..0000000 --- a/parsing_cocci/.#context_neg.ml.1.104 +++ /dev/null @@ -1,1023 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#data.ml.1.37 b/parsing_cocci/.#data.ml.1.37 deleted file mode 100644 index fe7c28d..0000000 --- a/parsing_cocci/.#data.ml.1.37 +++ /dev/null @@ -1,148 +0,0 @@ -(* -* 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 . -* -* 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") diff --git a/parsing_cocci/.#data.ml.1.38 b/parsing_cocci/.#data.ml.1.38 deleted file mode 100644 index f6fe909..0000000 --- a/parsing_cocci/.#data.ml.1.38 +++ /dev/null @@ -1,151 +0,0 @@ -(* -* 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 . -* -* 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") diff --git a/parsing_cocci/.#disjdistr.ml.1.27 b/parsing_cocci/.#disjdistr.ml.1.27 deleted file mode 100644 index ae7679f..0000000 --- a/parsing_cocci/.#disjdistr.ml.1.27 +++ /dev/null @@ -1,395 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#free_vars.ml.1.83 b/parsing_cocci/.#free_vars.ml.1.83 deleted file mode 100644 index dabf51c..0000000 --- a/parsing_cocci/.#free_vars.ml.1.83 +++ /dev/null @@ -1,787 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#index.ml.1.59 b/parsing_cocci/.#index.ml.1.59 deleted file mode 100644 index 2f3752c..0000000 --- a/parsing_cocci/.#index.ml.1.59 +++ /dev/null @@ -1,222 +0,0 @@ -(* -* 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 . -* -* 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 *) diff --git a/parsing_cocci/.#index.ml.1.60 b/parsing_cocci/.#index.ml.1.60 deleted file mode 100644 index a28bb8d..0000000 --- a/parsing_cocci/.#index.ml.1.60 +++ /dev/null @@ -1,221 +0,0 @@ -(* -* 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 . -* -* 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 *) diff --git a/parsing_cocci/.#insert_plus.ml.1.74 b/parsing_cocci/.#insert_plus.ml.1.74 deleted file mode 100644 index 706f922..0000000 --- a/parsing_cocci/.#insert_plus.ml.1.74 +++ /dev/null @@ -1,952 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#iso_pattern.ml.1.150 b/parsing_cocci/.#iso_pattern.ml.1.150 deleted file mode 100644 index 0afc05b..0000000 --- a/parsing_cocci/.#iso_pattern.ml.1.150 +++ /dev/null @@ -1,2342 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#iso_pattern.ml.1.152 b/parsing_cocci/.#iso_pattern.ml.1.152 deleted file mode 100644 index 2a3bb2e..0000000 --- a/parsing_cocci/.#iso_pattern.ml.1.152 +++ /dev/null @@ -1,2379 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#lexer_cocci.mll.1.84 b/parsing_cocci/.#lexer_cocci.mll.1.84 deleted file mode 100644 index 28e7093..0000000 --- a/parsing_cocci/.#lexer_cocci.mll.1.84 +++ /dev/null @@ -1,704 +0,0 @@ -(* -* 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 . -* -* 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) } -(* - | "" { 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) } diff --git a/parsing_cocci/.#lexer_cocci.mll.1.86 b/parsing_cocci/.#lexer_cocci.mll.1.86 deleted file mode 100644 index f02c923..0000000 --- a/parsing_cocci/.#lexer_cocci.mll.1.86 +++ /dev/null @@ -1,712 +0,0 @@ -(* -* 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 . -* -* 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) } -(* - | "" { 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) } diff --git a/parsing_cocci/.#parse_aux.ml.1.26 b/parsing_cocci/.#parse_aux.ml.1.26 deleted file mode 100644 index 1190521..0000000 --- a/parsing_cocci/.#parse_aux.ml.1.26 +++ /dev/null @@ -1,475 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#parse_aux.ml.1.27 b/parsing_cocci/.#parse_aux.ml.1.27 deleted file mode 100644 index 91df7e7..0000000 --- a/parsing_cocci/.#parse_aux.ml.1.27 +++ /dev/null @@ -1,482 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#parse_cocci.ml.1.178 b/parsing_cocci/.#parse_cocci.ml.1.178 deleted file mode 100644 index bd217cc..0000000 --- a/parsing_cocci/.#parse_cocci.ml.1.178 +++ /dev/null @@ -1,1598 +0,0 @@ -(* -* 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 . -* -* 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.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) diff --git a/parsing_cocci/.#parse_cocci.ml.1.180 b/parsing_cocci/.#parse_cocci.ml.1.180 deleted file mode 100644 index 91c0768..0000000 --- a/parsing_cocci/.#parse_cocci.ml.1.180 +++ /dev/null @@ -1,1628 +0,0 @@ -(* -* 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 . -* -* 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.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) diff --git a/parsing_cocci/.#parser_cocci_menhir.mly.1.166 b/parsing_cocci/.#parser_cocci_menhir.mly.1.166 deleted file mode 100644 index 8172b30..0000000 --- a/parsing_cocci/.#parser_cocci_menhir.mly.1.166 +++ /dev/null @@ -1,1847 +0,0 @@ -/* -* 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 . -* -* 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 TRuleName - -%token Tchar Tshort Tint Tdouble Tfloat Tlong -%token Tvoid Tstruct Tunion Tenum -%token Tunsigned Tsigned - -%token Tstatic Tauto Tregister Textern Tinline Ttypedef -%token Tconst Tvolatile -%token Tattr - -%token TIf TElse TWhile TFor TDo TSwitch TCase TDefault TReturn -%token TBreak TContinue TGoto TSizeof TFunDecl -%token TIdent TTypeId TDeclarerId TIteratorId - -%token TMetaId TMetaFunc TMetaLocalFunc -%token TMetaIterator TMetaDeclarer -%token TMetaErr -%token TMetaParam TMetaStm TMetaStmList TMetaType -%token TMetaParamList TMetaExpList -%token TMetaExp TMetaIdExp TMetaLocalIdExp TMetaConst -%token TMetaPos - -%token TArob TArobArob TPArob -%token TScriptData - -%token TEllipsis TOEllipsis TCEllipsis TPOEllipsis TPCEllipsis -%token TWhen TWhenTrue TWhenFalse TAny TStrict TLineEnd - -%token TWhy TDotDot TBang TOPar TOPar0 -%token TMid0 TCPar TCPar0 - -%token TPragma TPathIsoFile -%token TIncludeL TIncludeNL -%token TDefine -%token TDefineParam -%token TMinusFile TPlusFile - -%token TInc TDec - -%token TString TChar TFloat TInt - -%token TOrLog -%token TAndLog -%token TOr -%token TXor -%token TAnd -%token TEqEq TNotEq -%token TLogOp /* TInf TSup TInfEq TSupEq */ -%token TShOp /* TShl TShr */ -%token TDmOp /* TDiv TMod */ -%token TPlus TMinus -%token TMul TTilde - -%token TOBrace TCBrace TOInit -%token TOCro TCCro - -%token TPtrOp - -%token TMPtVirg -%token TEq TDot TComma TPtVirg -%token 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 reinit - -%start minus_main -%type minus_main - -%start minus_exp_main -%type minus_exp_main - -%start plus_main -%type plus_main - -%start plus_exp_main -%type plus_exp_main - -%start include_main -%type <(string,string) Common.either list> include_main - -%start iso_rule_name -%type -iso_rule_name - -%start rule_name -%type -rule_name - -%start meta_main -%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> meta_main - -%start script_meta_main - -%start iso_main -%type iso_main - -%start iso_meta_main -%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> iso_meta_main - -%start never_used -%type 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)) } diff --git a/parsing_cocci/.#parser_cocci_menhir.mly.1.168 b/parsing_cocci/.#parser_cocci_menhir.mly.1.168 deleted file mode 100644 index 09fb8ad..0000000 --- a/parsing_cocci/.#parser_cocci_menhir.mly.1.168 +++ /dev/null @@ -1,1859 +0,0 @@ -/* -* 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 . -* -* 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 TRuleName - -%token Tchar Tshort Tint Tdouble Tfloat Tlong -%token Tvoid Tstruct Tunion Tenum -%token Tunsigned Tsigned - -%token Tstatic Tauto Tregister Textern Tinline Ttypedef -%token Tconst Tvolatile -%token Tattr - -%token TIf TElse TWhile TFor TDo TSwitch TCase TDefault TReturn -%token TBreak TContinue TGoto TSizeof TFunDecl -%token TIdent TTypeId TDeclarerId TIteratorId - -%token TMetaId TMetaFunc TMetaLocalFunc -%token TMetaIterator TMetaDeclarer -%token TMetaErr -%token TMetaParam TMetaStm TMetaStmList TMetaType -%token TMetaInit -%token TMetaParamList TMetaExpList -%token TMetaExp TMetaIdExp TMetaLocalIdExp TMetaConst -%token TMetaPos - -%token TArob TArobArob TPArob -%token TScriptData - -%token TEllipsis TOEllipsis TCEllipsis TPOEllipsis TPCEllipsis -%token TWhen TWhenTrue TWhenFalse TAny TStrict TLineEnd - -%token TWhy TDotDot TBang TOPar TOPar0 -%token TMid0 TCPar TCPar0 - -%token TPragma TPathIsoFile -%token TIncludeL TIncludeNL -%token TDefine -%token TDefineParam -%token TMinusFile TPlusFile - -%token TInc TDec - -%token TString TChar TFloat TInt - -%token TOrLog -%token TAndLog -%token TOr -%token TXor -%token TAnd -%token TEqEq TNotEq -%token TLogOp /* TInf TSup TInfEq TSupEq */ -%token TShOp /* TShl TShr */ -%token TDmOp /* TDiv TMod */ -%token TPlus TMinus -%token TMul TTilde - -%token TOBrace TCBrace TOInit -%token TOCro TCCro - -%token TPtrOp - -%token TMPtVirg -%token TEq TDot TComma TPtVirg -%token 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 reinit - -%start minus_main -%type minus_main - -%start minus_exp_main -%type minus_exp_main - -%start plus_main -%type plus_main - -%start plus_exp_main -%type plus_exp_main - -%start include_main -%type <(string,string) Common.either list> include_main - -%start iso_rule_name -%type -iso_rule_name - -%start rule_name -%type -rule_name - -%start meta_main -%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> meta_main - -%start script_meta_main - -%start iso_main -%type iso_main - -%start iso_meta_main -%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> iso_meta_main - -%start never_used -%type 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)) } diff --git a/parsing_cocci/.#parser_cocci_menhir.mly.1.169 b/parsing_cocci/.#parser_cocci_menhir.mly.1.169 deleted file mode 100644 index 71ed6ef..0000000 --- a/parsing_cocci/.#parser_cocci_menhir.mly.1.169 +++ /dev/null @@ -1,1859 +0,0 @@ -/* -* 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 . -* -* 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 TRuleName - -%token Tchar Tshort Tint Tdouble Tfloat Tlong -%token Tvoid Tstruct Tunion Tenum -%token Tunsigned Tsigned - -%token Tstatic Tauto Tregister Textern Tinline Ttypedef -%token Tconst Tvolatile -%token Tattr - -%token TIf TElse TWhile TFor TDo TSwitch TCase TDefault TReturn -%token TBreak TContinue TGoto TSizeof TFunDecl -%token TIdent TTypeId TDeclarerId TIteratorId - -%token TMetaId TMetaFunc TMetaLocalFunc -%token TMetaIterator TMetaDeclarer -%token TMetaErr -%token TMetaParam TMetaStm TMetaStmList TMetaType -%token TMetaInit -%token TMetaParamList TMetaExpList -%token TMetaExp TMetaIdExp TMetaLocalIdExp TMetaConst -%token TMetaPos - -%token TArob TArobArob TPArob -%token TScriptData - -%token TEllipsis TOEllipsis TCEllipsis TPOEllipsis TPCEllipsis -%token TWhen TWhenTrue TWhenFalse TAny TStrict TLineEnd - -%token TWhy TDotDot TBang TOPar TOPar0 -%token TMid0 TCPar TCPar0 - -%token TPragma TPathIsoFile -%token TIncludeL TIncludeNL -%token TDefine -%token TDefineParam -%token TMinusFile TPlusFile - -%token TInc TDec - -%token TString TChar TFloat TInt - -%token TOrLog -%token TAndLog -%token TOr -%token TXor -%token TAnd -%token TEqEq TNotEq -%token TLogOp /* TInf TSup TInfEq TSupEq */ -%token TShOp /* TShl TShr */ -%token TDmOp /* TDiv TMod */ -%token TPlus TMinus -%token TMul TTilde - -%token TOBrace TCBrace TOInit -%token TOCro TCCro - -%token TPtrOp - -%token TMPtVirg -%token TEq TDot TComma TPtVirg -%token 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 reinit - -%start minus_main -%type minus_main - -%start minus_exp_main -%type minus_exp_main - -%start plus_main -%type plus_main - -%start plus_exp_main -%type plus_exp_main - -%start include_main -%type <(string,string) Common.either list> include_main - -%start iso_rule_name -%type -iso_rule_name - -%start rule_name -%type -rule_name - -%start meta_main -%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> meta_main - -%start script_meta_main - -%start iso_main -%type iso_main - -%start iso_meta_main -%type <(Ast_cocci.metavar,Ast_cocci.metavar) Common.either list> iso_meta_main - -%start never_used -%type 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)) } diff --git a/parsing_cocci/.#pretty_print_cocci.ml.1.134 b/parsing_cocci/.#pretty_print_cocci.ml.1.134 deleted file mode 100644 index 0928872..0000000 --- a/parsing_cocci/.#pretty_print_cocci.ml.1.134 +++ /dev/null @@ -1,864 +0,0 @@ -(* -* 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 . -* -* 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 - diff --git a/parsing_cocci/.#pretty_print_cocci.ml.1.135 b/parsing_cocci/.#pretty_print_cocci.ml.1.135 deleted file mode 100644 index 9675e49..0000000 --- a/parsing_cocci/.#pretty_print_cocci.ml.1.135 +++ /dev/null @@ -1,865 +0,0 @@ -(* -* 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 . -* -* 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 - diff --git a/parsing_cocci/.#type_infer.ml.1.60 b/parsing_cocci/.#type_infer.ml.1.60 deleted file mode 100644 index 24448ad..0000000 --- a/parsing_cocci/.#type_infer.ml.1.60 +++ /dev/null @@ -1,384 +0,0 @@ -(* -* 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 . -* -* 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 - () diff --git a/parsing_cocci/.#unify_ast.ml.1.75 b/parsing_cocci/.#unify_ast.ml.1.75 deleted file mode 100644 index 6d14682..0000000 --- a/parsing_cocci/.#unify_ast.ml.1.75 +++ /dev/null @@ -1,574 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/parsing_cocci/.#unparse_ast0.ml.1.116 b/parsing_cocci/.#unparse_ast0.ml.1.116 deleted file mode 100644 index fe3dd11..0000000 --- a/parsing_cocci/.#unparse_ast0.ml.1.116 +++ /dev/null @@ -1,667 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#unparse_ast0.ml.1.118 b/parsing_cocci/.#unparse_ast0.ml.1.118 deleted file mode 100644 index b295646..0000000 --- a/parsing_cocci/.#unparse_ast0.ml.1.118 +++ /dev/null @@ -1,667 +0,0 @@ -(* -* 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 . -* -* 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) diff --git a/parsing_cocci/.#visitor_ast.ml.1.95 b/parsing_cocci/.#visitor_ast.ml.1.95 deleted file mode 100644 index 6541953..0000000 --- a/parsing_cocci/.#visitor_ast.ml.1.95 +++ /dev/null @@ -1,1056 +0,0 @@ -(* -* 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 . -* -* 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 - diff --git a/parsing_cocci/.#visitor_ast.ml.1.97 b/parsing_cocci/.#visitor_ast.ml.1.97 deleted file mode 100644 index f0ca9c8..0000000 --- a/parsing_cocci/.#visitor_ast.ml.1.97 +++ /dev/null @@ -1,1061 +0,0 @@ -(* -* 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 . -* -* 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 - diff --git a/parsing_cocci/.#visitor_ast0.ml.1.87 b/parsing_cocci/.#visitor_ast0.ml.1.87 deleted file mode 100644 index 8a5bd6e..0000000 --- a/parsing_cocci/.#visitor_ast0.ml.1.87 +++ /dev/null @@ -1,1041 +0,0 @@ -(* -* 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 . -* -* 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 diff --git a/popl/.#Makefile.1.5 b/popl/.#Makefile.1.5 deleted file mode 100644 index 2254a1e..0000000 --- a/popl/.#Makefile.1.5 +++ /dev/null @@ -1,102 +0,0 @@ -# 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 . -# -# 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 diff --git a/popl09/.#Makefile.1.5 b/popl09/.#Makefile.1.5 deleted file mode 100644 index 83c32f1..0000000 --- a/popl09/.#Makefile.1.5 +++ /dev/null @@ -1,101 +0,0 @@ -# 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 . -# -# 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 diff --git a/popl09/.#Makefile.1.6 b/popl09/.#Makefile.1.6 deleted file mode 100644 index f773e1a..0000000 --- a/popl09/.#Makefile.1.6 +++ /dev/null @@ -1,101 +0,0 @@ -# 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 . -# -# 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 diff --git a/python/.#Makefile.1.5 b/python/.#Makefile.1.5 deleted file mode 100644 index d2a67ec..0000000 --- a/python/.#Makefile.1.5 +++ /dev/null @@ -1,146 +0,0 @@ -# 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 . -# -# 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 diff --git a/python/.#no_pycocci_aux.ml.1.2 b/python/.#no_pycocci_aux.ml.1.2 deleted file mode 100644 index e4ded17..0000000 --- a/python/.#no_pycocci_aux.ml.1.2 +++ /dev/null @@ -1,76 +0,0 @@ -(* -* 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 . -* -* 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: <>" -| Ast_c.MetaExprListVal expr_list -> "TODO: <>" -| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ -| Ast_c.MetaStmtVal statement -> "TODO: stmt" -| Ast_c.MetaParamVal params -> "TODO: <>" -| Ast_c.MetaParamListVal params -> "TODO: <>" -| Ast_c.MetaListlenVal n -> string_of_int n -| Ast_c.MetaPosVal (pos1, pos2) -> - (* Common.sprintf ("pos(%d,%d)") pos1 pos2 *) - "TODO: <>" -| Ast_c.MetaPosValList positions -> "TODO: <>" - diff --git a/python/.#yes_pycocci.ml.1.2 b/python/.#yes_pycocci.ml.1.2 deleted file mode 100644 index 4f55845..0000000 --- a/python/.#yes_pycocci.ml.1.2 +++ /dev/null @@ -1,243 +0,0 @@ -(* -* 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 . -* -* 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 () diff --git a/python/.#yes_pycocci_aux.ml.1.1 b/python/.#yes_pycocci_aux.ml.1.1 deleted file mode 100644 index 1566b64..0000000 --- a/python/.#yes_pycocci_aux.ml.1.1 +++ /dev/null @@ -1,79 +0,0 @@ -(* -* 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 . -* -* 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: <>" -| Ast_c.MetaExprListVal expr_list -> "TODO: <>" -| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ -| Ast_c.MetaStmtVal statement -> "TODO: stmt" -| Ast_c.MetaParamVal params -> "TODO: <>" -| Ast_c.MetaParamListVal params -> "TODO: <>" -| 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: <>" - diff --git a/python/.#yes_pycocci_aux.ml.1.2 b/python/.#yes_pycocci_aux.ml.1.2 deleted file mode 100644 index 8c5af0b..0000000 --- a/python/.#yes_pycocci_aux.ml.1.2 +++ /dev/null @@ -1,80 +0,0 @@ -(* -* 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 . -* -* 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: <>" -| Ast_c.MetaExprListVal expr_list -> "TODO: <>" -| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ -| Ast_c.MetaInitVal ini -> "TODO: <>" -| Ast_c.MetaStmtVal statement -> "TODO: stmt" -| Ast_c.MetaParamVal params -> "TODO: <>" -| Ast_c.MetaParamListVal params -> "TODO: <>" -| 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: <>" - diff --git a/python/.#yes_pycocci_aux.ml.1.3 b/python/.#yes_pycocci_aux.ml.1.3 deleted file mode 100644 index afe3bf5..0000000 --- a/python/.#yes_pycocci_aux.ml.1.3 +++ /dev/null @@ -1,80 +0,0 @@ -(* -* 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 . -* -* 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: <>" -| Ast_c.MetaExprListVal expr_list -> "TODO: <>" -| Ast_c.MetaTypeVal typ -> call_pretty Pretty_print_c.pp_type_gen typ -| Ast_c.MetaInitVal ini -> "TODO: <>" -| Ast_c.MetaStmtVal statement -> "TODO: stmt" -| Ast_c.MetaParamVal params -> "TODO: <>" -| Ast_c.MetaParamListVal params -> "TODO: <>" -| 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: <>" - diff --git a/runspatch.opt b/runspatch.opt index dbe2b2f..bf69d9d 100755 --- a/runspatch.opt +++ b/runspatch.opt @@ -1,4 +1,4 @@ -#!/bin/bash +#!/bin/sh DN=`dirname $0` if [ -z ${PYTHONPATH} ] diff --git a/scripts/spatch.sh b/scripts/spatch.sh dissimilarity index 67% index 18461e5..dd53353 100644 --- a/scripts/spatch.sh +++ b/scripts/spatch.sh @@ -1,20 +1,21 @@ -#!/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 "$@" + diff --git a/tools/alloc_free.ml b/tools/alloc_free.ml index 48b0ea7..1c91280 100644 --- a/tools/alloc_free.ml +++ b/tools/alloc_free.ml @@ -167,7 +167,7 @@ let _ = 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"; -- 2.20.1