From 93d89c2b5e8497365be152fb53cb6cd4c5764d34 Mon Sep 17 00:00:00 2001 From: xleroy Date: Wed, 3 Mar 2010 10:25:25 +0000 Subject: Getting rid of CIL git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1270 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cfrontend/Cil2Csyntax.ml | 1283 ----- cil/INSTALL | 41 - cil/LICENSE | 35 - cil/Makefile.gcc | 75 - cil/Makefile.in | 656 --- cil/Makefile.msvc | 42 - cil/README | 2 - cil/bin/CilConfig.pm.in | 6 - cil/bin/cilly | 152 - cil/bin/cilly.bat.in | 1 - cil/bin/patcher | 605 -- cil/bin/patcher.bat.in | 1 - cil/bin/teetwo | 36 - cil/bin/test-bad | 202 - cil/cil.spec | 90 - cil/cil.spec.in | 90 - cil/config.guess | 1497 ----- cil/config.h.in | 23 - cil/config.sub | 1469 ----- cil/configure | 5697 ------------------- cil/configure.in | 600 -- cil/doc/CIL-API.pdf | Bin 226152 -> 0 bytes cil/doc/CIL.pdf | Bin 269328 -> 0 bytes cil/doc/api/Alpha.html | 79 - cil/doc/api/Cfg.html | 69 - cil/doc/api/Cil.cilPrinter.html | 118 - cil/doc/api/Cil.cilVisitor.html | 125 - cil/doc/api/Cil.defaultCilPrinterClass.html | 36 - cil/doc/api/Cil.html | 3337 ----------- cil/doc/api/Cil.nopCilVisitor.html | 35 - cil/doc/api/Cil.plainCilPrinterClass.html | 36 - cil/doc/api/Cillower.html | 40 - cil/doc/api/Clist.html | 118 - cil/doc/api/Dataflow.BackwardsDataFlow.html | 54 - cil/doc/api/Dataflow.BackwardsTransfer.html | 83 - cil/doc/api/Dataflow.ForwardsDataFlow.html | 53 - cil/doc/api/Dataflow.ForwardsTransfer.html | 88 - cil/doc/api/Dataflow.html | 114 - cil/doc/api/Dominators.html | 58 - cil/doc/api/Errormsg.html | 141 - cil/doc/api/Formatcil.html | 84 - cil/doc/api/Pretty.MakeMapPrinter.html | 63 - cil/doc/api/Pretty.MakeSetPrinter.html | 63 - cil/doc/api/Pretty.html | 268 - cil/doc/api/Stats.html | 69 - cil/doc/api/index.html | 83 - cil/doc/api/index_attributes.html | 30 - cil/doc/api/index_class_types.html | 41 - cil/doc/api/index_classes.html | 46 - cil/doc/api/index_exceptions.html | 53 - cil/doc/api/index_methods.html | 228 - cil/doc/api/index_module_types.html | 36 - cil/doc/api/index_modules.html | 108 - cil/doc/api/index_types.html | 271 - cil/doc/api/index_values.html | 1964 ------- cil/doc/api/style.css | 32 - cil/doc/api/type_Alpha.html | 43 - cil/doc/api/type_Cfg.html | 35 - cil/doc/api/type_Cil.cilPrinter.html | 48 - cil/doc/api/type_Cil.cilVisitor.html | 43 - cil/doc/api/type_Cil.defaultCilPrinterClass.html | 25 - cil/doc/api/type_Cil.html | 622 --- cil/doc/api/type_Cil.nopCilVisitor.html | 25 - cil/doc/api/type_Cil.plainCilPrinterClass.html | 25 - cil/doc/api/type_Cillower.html | 25 - cil/doc/api/type_Clist.html | 44 - cil/doc/api/type_Dataflow.BackwardsDataFlow.html | 26 - cil/doc/api/type_Dataflow.BackwardsTransfer.html | 44 - cil/doc/api/type_Dataflow.ForwardsDataFlow.html | 25 - cil/doc/api/type_Dataflow.ForwardsTransfer.html | 51 - cil/doc/api/type_Dataflow.html | 85 - cil/doc/api/type_Dominators.html | 32 - cil/doc/api/type_Errormsg.html | 64 - cil/doc/api/type_Formatcil.html | 45 - cil/doc/api/type_Pretty.MakeMapPrinter.html | 42 - cil/doc/api/type_Pretty.MakeSetPrinter.html | 40 - cil/doc/api/type_Pretty.html | 111 - cil/doc/api/type_Stats.html | 36 - cil/doc/changes.html | 486 -- cil/doc/cil.css | 10 - cil/doc/cil.html | 3532 ------------ cil/doc/cil.version.tex | 2 - cil/doc/cil001.html | 134 - cil/doc/cil002.html | 98 - cil/doc/cil003.html | 187 - cil/doc/cil004.html | 350 -- cil/doc/cil006.html | 627 --- cil/doc/cil007.html | 279 - cil/doc/cil009.html | 48 - cil/doc/cil010.html | 100 - cil/doc/cil011.html | 53 - cil/doc/cil012.html | 133 - cil/doc/cil015.html | 60 - cil/doc/cil016.html | 342 -- cil/doc/cil017.html | 53 - cil/doc/cil018.html | 71 - cil/doc/cil019.html | 45 - cil/doc/cilly.html | 187 - cil/doc/cilpp.haux | 64 - cil/doc/cilpp.htoc | 65 - cil/doc/ciltoc.html | 92 - cil/doc/contents_motif.gif | Bin 316 -> 0 bytes cil/doc/examples/ex1.txt | 16 - cil/doc/examples/ex10.txt | 10 - cil/doc/examples/ex11.txt | 5 - cil/doc/examples/ex12.txt | 32 - cil/doc/examples/ex13.txt | 21 - cil/doc/examples/ex14.txt | 22 - cil/doc/examples/ex15.txt | 14 - cil/doc/examples/ex16.txt | 22 - cil/doc/examples/ex17.txt | 81 - cil/doc/examples/ex18.txt | 20 - cil/doc/examples/ex19.txt | 42 - cil/doc/examples/ex2.txt | 9 - cil/doc/examples/ex20.txt | 26 - cil/doc/examples/ex21.txt | 25 - cil/doc/examples/ex22.txt | 16 - cil/doc/examples/ex23.txt | 56 - cil/doc/examples/ex24.txt | 59 - cil/doc/examples/ex25.txt | 40 - cil/doc/examples/ex26.txt | 29 - cil/doc/examples/ex27.txt | 51 - cil/doc/examples/ex28.txt | 24 - cil/doc/examples/ex29.txt | 53 - cil/doc/examples/ex3.txt | 20 - cil/doc/examples/ex30.txt | 12 - cil/doc/examples/ex31.txt | 12 - cil/doc/examples/ex32.txt | 16 - cil/doc/examples/ex33.txt | 24 - cil/doc/examples/ex34.txt | 15 - cil/doc/examples/ex35.txt | 32 - cil/doc/examples/ex36.txt | 20 - cil/doc/examples/ex37.txt | 14 - cil/doc/examples/ex38.txt | 12 - cil/doc/examples/ex39.txt | 25 - cil/doc/examples/ex4.txt | 16 - cil/doc/examples/ex40.txt | 20 - cil/doc/examples/ex41.txt | 69 - cil/doc/examples/ex42.txt | 22 - cil/doc/examples/ex43.txt | 46 - cil/doc/examples/ex44.txt | 31 - cil/doc/examples/ex45.txt | 11 - cil/doc/examples/ex46.txt | 23 - cil/doc/examples/ex47.txt | 28 - cil/doc/examples/ex5.txt | 27 - cil/doc/examples/ex6.txt | 7 - cil/doc/examples/ex7.txt | 22 - cil/doc/examples/ex8.txt | 13 - cil/doc/examples/ex9.txt | 16 - cil/doc/ext.html | 506 -- cil/doc/header.html | 18 - cil/doc/index.html | 26 - cil/doc/merger.html | 167 - cil/doc/next_motif.gif | Bin 317 -> 0 bytes cil/doc/patcher.html | 126 - cil/doc/previous_motif.gif | Bin 317 -> 0 bytes cil/install-sh | 251 - cil/lib/Cilly.pm | 2137 ------- cil/lib/KeptFile.pm | 88 - cil/lib/OutputFile.pm | 213 - cil/lib/TempFile.pm | 90 - cil/ocamlutil/Makefile.ocaml | 395 -- cil/ocamlutil/Makefile.ocaml.build | 50 - cil/ocamlutil/alpha.ml | 156 - cil/ocamlutil/alpha.mli | 50 - cil/ocamlutil/clist.ml | 183 - cil/ocamlutil/clist.mli | 97 - cil/ocamlutil/errormsg.ml | 337 -- cil/ocamlutil/errormsg.mli | 164 - cil/ocamlutil/growArray.ml | 191 - cil/ocamlutil/growArray.mli | 131 - cil/ocamlutil/inthash.ml | 188 - cil/ocamlutil/inthash.mli | 27 - cil/ocamlutil/intmap.ml | 171 - cil/ocamlutil/intmap.mli | 87 - cil/ocamlutil/perfcount.c.in | 184 - cil/ocamlutil/pretty.ml | 859 --- cil/ocamlutil/pretty.mli | 316 -- cil/ocamlutil/stats.ml | 146 - cil/ocamlutil/stats.mli | 72 - cil/ocamlutil/trace.ml | 169 - cil/ocamlutil/trace.mli | 106 - cil/ocamlutil/util.ml | 815 --- cil/ocamlutil/util.mli | 311 -- cil/src/check.ml | 1017 ---- cil/src/check.mli | 45 - cil/src/cil.ml | 6427 ---------------------- cil/src/cil.mli | 2455 --------- cil/src/cillower.ml | 57 - cil/src/cillower.mli | 42 - cil/src/ciloptions.ml | 196 - cil/src/ciloptions.mli | 48 - cil/src/cilutil.ml | 72 - cil/src/escape.ml | 93 - cil/src/escape.mli | 48 - cil/src/ext/astslicer.ml | 454 -- cil/src/ext/availexps.ml | 359 -- cil/src/ext/bitmap.ml | 224 - cil/src/ext/bitmap.mli | 50 - cil/src/ext/blockinggraph.ml | 769 --- cil/src/ext/blockinggraph.mli | 40 - cil/src/ext/callgraph.ml | 250 - cil/src/ext/callgraph.mli | 123 - cil/src/ext/canonicalize.ml | 292 - cil/src/ext/canonicalize.mli | 48 - cil/src/ext/cfg.ml | 289 - cil/src/ext/cfg.mli | 36 - cil/src/ext/ciltools.ml | 228 - cil/src/ext/dataflow.ml | 466 -- cil/src/ext/dataflow.mli | 151 - cil/src/ext/dataslicing.ml | 462 -- cil/src/ext/dataslicing.mli | 41 - cil/src/ext/deadcodeelim.ml | 173 - cil/src/ext/dominators.ml | 241 - cil/src/ext/dominators.mli | 29 - cil/src/ext/epicenter.ml | 114 - cil/src/ext/heap.ml | 112 - cil/src/ext/heapify.ml | 250 - cil/src/ext/liveness.ml | 190 - cil/src/ext/logcalls.ml | 268 - cil/src/ext/logcalls.mli | 41 - cil/src/ext/logwrites.ml | 139 - cil/src/ext/oneret.ml | 187 - cil/src/ext/oneret.mli | 44 - cil/src/ext/partial.ml | 851 --- cil/src/ext/pta/golf.ml | 1657 ------ cil/src/ext/pta/golf.mli | 83 - cil/src/ext/pta/olf.ml | 1108 ---- cil/src/ext/pta/olf.mli | 80 - cil/src/ext/pta/ptranal.ml | 597 -- cil/src/ext/pta/ptranal.mli | 156 - cil/src/ext/pta/setp.ml | 342 -- cil/src/ext/pta/setp.mli | 180 - cil/src/ext/pta/steensgaard.ml | 1417 ----- cil/src/ext/pta/steensgaard.mli | 71 - cil/src/ext/pta/uref.ml | 94 - cil/src/ext/pta/uref.mli | 65 - cil/src/ext/reachingdefs.ml | 511 -- cil/src/ext/sfi.ml | 337 -- cil/src/ext/simplemem.ml | 132 - cil/src/ext/simplify.ml | 845 --- cil/src/ext/ssa.ml | 696 --- cil/src/ext/ssa.mli | 45 - cil/src/ext/stackoverflow.ml | 246 - cil/src/ext/stackoverflow.mli | 43 - cil/src/ext/usedef.ml | 188 - cil/src/formatcil.ml | 215 - cil/src/formatcil.mli | 103 - cil/src/formatlex.mll | 308 -- cil/src/formatparse.mly | 1455 ----- cil/src/frontc/cabs.ml | 396 -- cil/src/frontc/cabs2cil.ml | 6238 --------------------- cil/src/frontc/cabs2cil.mli | 49 - cil/src/frontc/cabsvisit.ml | 577 -- cil/src/frontc/cabsvisit.mli | 115 - cil/src/frontc/clexer.mli | 55 - cil/src/frontc/clexer.mll | 666 --- cil/src/frontc/cparser.mly | 1521 ----- cil/src/frontc/cprint.ml | 1014 ---- cil/src/frontc/frontc.ml | 256 - cil/src/frontc/frontc.mli | 55 - cil/src/frontc/lexerhack.ml | 22 - cil/src/frontc/patch.ml | 837 --- cil/src/frontc/patch.mli | 42 - cil/src/libmaincil.ml | 108 - cil/src/machdep.c | 220 - cil/src/main.ml | 288 - cil/src/mergecil.ml | 1770 ------ cil/src/mergecil.mli | 42 - cil/src/rmtmps.ml | 778 --- cil/src/rmtmps.mli | 82 - cil/src/testcil.ml | 440 -- cil/test/small1/func.c | 24 - cil/test/small1/hello.c | 8 - cil/test/small1/init.c | 177 - cil/test/small1/init1.c | 17 - cil/test/small1/testharness.h | 17 - cil/test/small1/vararg1.c | 47 - cil/test/small1/wchar1.c | 24 - configure | 8 - 280 files changed, 83521 deletions(-) delete mode 100644 cfrontend/Cil2Csyntax.ml delete mode 100644 cil/INSTALL delete mode 100644 cil/LICENSE delete mode 100644 cil/Makefile.gcc delete mode 100644 cil/Makefile.in delete mode 100644 cil/Makefile.msvc delete mode 100644 cil/README delete mode 100644 cil/bin/CilConfig.pm.in delete mode 100755 cil/bin/cilly delete mode 100755 cil/bin/cilly.bat.in delete mode 100755 cil/bin/patcher delete mode 100755 cil/bin/patcher.bat.in delete mode 100755 cil/bin/teetwo delete mode 100755 cil/bin/test-bad delete mode 100644 cil/cil.spec delete mode 100644 cil/cil.spec.in delete mode 100755 cil/config.guess delete mode 100644 cil/config.h.in delete mode 100755 cil/config.sub delete mode 100755 cil/configure delete mode 100644 cil/configure.in delete mode 100644 cil/doc/CIL-API.pdf delete mode 100644 cil/doc/CIL.pdf delete mode 100644 cil/doc/api/Alpha.html delete mode 100644 cil/doc/api/Cfg.html delete mode 100644 cil/doc/api/Cil.cilPrinter.html delete mode 100644 cil/doc/api/Cil.cilVisitor.html delete mode 100644 cil/doc/api/Cil.defaultCilPrinterClass.html delete mode 100644 cil/doc/api/Cil.html delete mode 100644 cil/doc/api/Cil.nopCilVisitor.html delete mode 100644 cil/doc/api/Cil.plainCilPrinterClass.html delete mode 100644 cil/doc/api/Cillower.html delete mode 100644 cil/doc/api/Clist.html delete mode 100644 cil/doc/api/Dataflow.BackwardsDataFlow.html delete mode 100644 cil/doc/api/Dataflow.BackwardsTransfer.html delete mode 100644 cil/doc/api/Dataflow.ForwardsDataFlow.html delete mode 100644 cil/doc/api/Dataflow.ForwardsTransfer.html delete mode 100644 cil/doc/api/Dataflow.html delete mode 100644 cil/doc/api/Dominators.html delete mode 100644 cil/doc/api/Errormsg.html delete mode 100644 cil/doc/api/Formatcil.html delete mode 100644 cil/doc/api/Pretty.MakeMapPrinter.html delete mode 100644 cil/doc/api/Pretty.MakeSetPrinter.html delete mode 100644 cil/doc/api/Pretty.html delete mode 100644 cil/doc/api/Stats.html delete mode 100644 cil/doc/api/index.html delete mode 100644 cil/doc/api/index_attributes.html delete mode 100644 cil/doc/api/index_class_types.html delete mode 100644 cil/doc/api/index_classes.html delete mode 100644 cil/doc/api/index_exceptions.html delete mode 100644 cil/doc/api/index_methods.html delete mode 100644 cil/doc/api/index_module_types.html delete mode 100644 cil/doc/api/index_modules.html delete mode 100644 cil/doc/api/index_types.html delete mode 100644 cil/doc/api/index_values.html delete mode 100644 cil/doc/api/style.css delete mode 100644 cil/doc/api/type_Alpha.html delete mode 100644 cil/doc/api/type_Cfg.html delete mode 100644 cil/doc/api/type_Cil.cilPrinter.html delete mode 100644 cil/doc/api/type_Cil.cilVisitor.html delete mode 100644 cil/doc/api/type_Cil.defaultCilPrinterClass.html delete mode 100644 cil/doc/api/type_Cil.html delete mode 100644 cil/doc/api/type_Cil.nopCilVisitor.html delete mode 100644 cil/doc/api/type_Cil.plainCilPrinterClass.html delete mode 100644 cil/doc/api/type_Cillower.html delete mode 100644 cil/doc/api/type_Clist.html delete mode 100644 cil/doc/api/type_Dataflow.BackwardsDataFlow.html delete mode 100644 cil/doc/api/type_Dataflow.BackwardsTransfer.html delete mode 100644 cil/doc/api/type_Dataflow.ForwardsDataFlow.html delete mode 100644 cil/doc/api/type_Dataflow.ForwardsTransfer.html delete mode 100644 cil/doc/api/type_Dataflow.html delete mode 100644 cil/doc/api/type_Dominators.html delete mode 100644 cil/doc/api/type_Errormsg.html delete mode 100644 cil/doc/api/type_Formatcil.html delete mode 100644 cil/doc/api/type_Pretty.MakeMapPrinter.html delete mode 100644 cil/doc/api/type_Pretty.MakeSetPrinter.html delete mode 100644 cil/doc/api/type_Pretty.html delete mode 100644 cil/doc/api/type_Stats.html delete mode 100644 cil/doc/changes.html delete mode 100644 cil/doc/cil.css delete mode 100644 cil/doc/cil.html delete mode 100644 cil/doc/cil.version.tex delete mode 100644 cil/doc/cil001.html delete mode 100644 cil/doc/cil002.html delete mode 100644 cil/doc/cil003.html delete mode 100644 cil/doc/cil004.html delete mode 100644 cil/doc/cil006.html delete mode 100644 cil/doc/cil007.html delete mode 100644 cil/doc/cil009.html delete mode 100644 cil/doc/cil010.html delete mode 100644 cil/doc/cil011.html delete mode 100644 cil/doc/cil012.html delete mode 100644 cil/doc/cil015.html delete mode 100644 cil/doc/cil016.html delete mode 100644 cil/doc/cil017.html delete mode 100644 cil/doc/cil018.html delete mode 100644 cil/doc/cil019.html delete mode 100644 cil/doc/cilly.html delete mode 100644 cil/doc/cilpp.haux delete mode 100644 cil/doc/cilpp.htoc delete mode 100644 cil/doc/ciltoc.html delete mode 100644 cil/doc/contents_motif.gif delete mode 100644 cil/doc/examples/ex1.txt delete mode 100644 cil/doc/examples/ex10.txt delete mode 100644 cil/doc/examples/ex11.txt delete mode 100644 cil/doc/examples/ex12.txt delete mode 100644 cil/doc/examples/ex13.txt delete mode 100644 cil/doc/examples/ex14.txt delete mode 100644 cil/doc/examples/ex15.txt delete mode 100644 cil/doc/examples/ex16.txt delete mode 100644 cil/doc/examples/ex17.txt delete mode 100644 cil/doc/examples/ex18.txt delete mode 100644 cil/doc/examples/ex19.txt delete mode 100644 cil/doc/examples/ex2.txt delete mode 100644 cil/doc/examples/ex20.txt delete mode 100644 cil/doc/examples/ex21.txt delete mode 100644 cil/doc/examples/ex22.txt delete mode 100644 cil/doc/examples/ex23.txt delete mode 100644 cil/doc/examples/ex24.txt delete mode 100644 cil/doc/examples/ex25.txt delete mode 100644 cil/doc/examples/ex26.txt delete mode 100644 cil/doc/examples/ex27.txt delete mode 100644 cil/doc/examples/ex28.txt delete mode 100644 cil/doc/examples/ex29.txt delete mode 100644 cil/doc/examples/ex3.txt delete mode 100644 cil/doc/examples/ex30.txt delete mode 100644 cil/doc/examples/ex31.txt delete mode 100644 cil/doc/examples/ex32.txt delete mode 100644 cil/doc/examples/ex33.txt delete mode 100644 cil/doc/examples/ex34.txt delete mode 100644 cil/doc/examples/ex35.txt delete mode 100644 cil/doc/examples/ex36.txt delete mode 100644 cil/doc/examples/ex37.txt delete mode 100644 cil/doc/examples/ex38.txt delete mode 100644 cil/doc/examples/ex39.txt delete mode 100644 cil/doc/examples/ex4.txt delete mode 100644 cil/doc/examples/ex40.txt delete mode 100644 cil/doc/examples/ex41.txt delete mode 100644 cil/doc/examples/ex42.txt delete mode 100644 cil/doc/examples/ex43.txt delete mode 100644 cil/doc/examples/ex44.txt delete mode 100644 cil/doc/examples/ex45.txt delete mode 100644 cil/doc/examples/ex46.txt delete mode 100644 cil/doc/examples/ex47.txt delete mode 100644 cil/doc/examples/ex5.txt delete mode 100644 cil/doc/examples/ex6.txt delete mode 100644 cil/doc/examples/ex7.txt delete mode 100644 cil/doc/examples/ex8.txt delete mode 100644 cil/doc/examples/ex9.txt delete mode 100644 cil/doc/ext.html delete mode 100644 cil/doc/header.html delete mode 100644 cil/doc/index.html delete mode 100644 cil/doc/merger.html delete mode 100644 cil/doc/next_motif.gif delete mode 100644 cil/doc/patcher.html delete mode 100644 cil/doc/previous_motif.gif delete mode 100644 cil/install-sh delete mode 100644 cil/lib/Cilly.pm delete mode 100644 cil/lib/KeptFile.pm delete mode 100644 cil/lib/OutputFile.pm delete mode 100644 cil/lib/TempFile.pm delete mode 100644 cil/ocamlutil/Makefile.ocaml delete mode 100644 cil/ocamlutil/Makefile.ocaml.build delete mode 100755 cil/ocamlutil/alpha.ml delete mode 100755 cil/ocamlutil/alpha.mli delete mode 100644 cil/ocamlutil/clist.ml delete mode 100644 cil/ocamlutil/clist.mli delete mode 100644 cil/ocamlutil/errormsg.ml delete mode 100644 cil/ocamlutil/errormsg.mli delete mode 100644 cil/ocamlutil/growArray.ml delete mode 100644 cil/ocamlutil/growArray.mli delete mode 100755 cil/ocamlutil/inthash.ml delete mode 100755 cil/ocamlutil/inthash.mli delete mode 100755 cil/ocamlutil/intmap.ml delete mode 100755 cil/ocamlutil/intmap.mli delete mode 100755 cil/ocamlutil/perfcount.c.in delete mode 100644 cil/ocamlutil/pretty.ml delete mode 100644 cil/ocamlutil/pretty.mli delete mode 100644 cil/ocamlutil/stats.ml delete mode 100644 cil/ocamlutil/stats.mli delete mode 100644 cil/ocamlutil/trace.ml delete mode 100644 cil/ocamlutil/trace.mli delete mode 100755 cil/ocamlutil/util.ml delete mode 100644 cil/ocamlutil/util.mli delete mode 100644 cil/src/check.ml delete mode 100644 cil/src/check.mli delete mode 100644 cil/src/cil.ml delete mode 100644 cil/src/cil.mli delete mode 100755 cil/src/cillower.ml delete mode 100755 cil/src/cillower.mli delete mode 100755 cil/src/ciloptions.ml delete mode 100755 cil/src/ciloptions.mli delete mode 100644 cil/src/cilutil.ml delete mode 100644 cil/src/escape.ml delete mode 100644 cil/src/escape.mli delete mode 100644 cil/src/ext/astslicer.ml delete mode 100644 cil/src/ext/availexps.ml delete mode 100644 cil/src/ext/bitmap.ml delete mode 100644 cil/src/ext/bitmap.mli delete mode 100644 cil/src/ext/blockinggraph.ml delete mode 100644 cil/src/ext/blockinggraph.mli delete mode 100644 cil/src/ext/callgraph.ml delete mode 100644 cil/src/ext/callgraph.mli delete mode 100644 cil/src/ext/canonicalize.ml delete mode 100644 cil/src/ext/canonicalize.mli delete mode 100644 cil/src/ext/cfg.ml delete mode 100644 cil/src/ext/cfg.mli delete mode 100755 cil/src/ext/ciltools.ml delete mode 100755 cil/src/ext/dataflow.ml delete mode 100755 cil/src/ext/dataflow.mli delete mode 100644 cil/src/ext/dataslicing.ml delete mode 100644 cil/src/ext/dataslicing.mli delete mode 100644 cil/src/ext/deadcodeelim.ml delete mode 100755 cil/src/ext/dominators.ml delete mode 100755 cil/src/ext/dominators.mli delete mode 100644 cil/src/ext/epicenter.ml delete mode 100644 cil/src/ext/heap.ml delete mode 100644 cil/src/ext/heapify.ml delete mode 100644 cil/src/ext/liveness.ml delete mode 100644 cil/src/ext/logcalls.ml delete mode 100644 cil/src/ext/logcalls.mli delete mode 100644 cil/src/ext/logwrites.ml delete mode 100644 cil/src/ext/oneret.ml delete mode 100644 cil/src/ext/oneret.mli delete mode 100644 cil/src/ext/partial.ml delete mode 100644 cil/src/ext/pta/golf.ml delete mode 100644 cil/src/ext/pta/golf.mli delete mode 100644 cil/src/ext/pta/olf.ml delete mode 100644 cil/src/ext/pta/olf.mli delete mode 100644 cil/src/ext/pta/ptranal.ml delete mode 100644 cil/src/ext/pta/ptranal.mli delete mode 100644 cil/src/ext/pta/setp.ml delete mode 100644 cil/src/ext/pta/setp.mli delete mode 100644 cil/src/ext/pta/steensgaard.ml delete mode 100644 cil/src/ext/pta/steensgaard.mli delete mode 100644 cil/src/ext/pta/uref.ml delete mode 100644 cil/src/ext/pta/uref.mli delete mode 100644 cil/src/ext/reachingdefs.ml delete mode 100755 cil/src/ext/sfi.ml delete mode 100644 cil/src/ext/simplemem.ml delete mode 100755 cil/src/ext/simplify.ml delete mode 100644 cil/src/ext/ssa.ml delete mode 100644 cil/src/ext/ssa.mli delete mode 100644 cil/src/ext/stackoverflow.ml delete mode 100644 cil/src/ext/stackoverflow.mli delete mode 100755 cil/src/ext/usedef.ml delete mode 100644 cil/src/formatcil.ml delete mode 100644 cil/src/formatcil.mli delete mode 100644 cil/src/formatlex.mll delete mode 100644 cil/src/formatparse.mly delete mode 100644 cil/src/frontc/cabs.ml delete mode 100644 cil/src/frontc/cabs2cil.ml delete mode 100644 cil/src/frontc/cabs2cil.mli delete mode 100644 cil/src/frontc/cabsvisit.ml delete mode 100644 cil/src/frontc/cabsvisit.mli delete mode 100644 cil/src/frontc/clexer.mli delete mode 100644 cil/src/frontc/clexer.mll delete mode 100644 cil/src/frontc/cparser.mly delete mode 100644 cil/src/frontc/cprint.ml delete mode 100644 cil/src/frontc/frontc.ml delete mode 100644 cil/src/frontc/frontc.mli delete mode 100755 cil/src/frontc/lexerhack.ml delete mode 100644 cil/src/frontc/patch.ml delete mode 100644 cil/src/frontc/patch.mli delete mode 100644 cil/src/libmaincil.ml delete mode 100644 cil/src/machdep.c delete mode 100644 cil/src/main.ml delete mode 100644 cil/src/mergecil.ml delete mode 100644 cil/src/mergecil.mli delete mode 100644 cil/src/rmtmps.ml delete mode 100644 cil/src/rmtmps.mli delete mode 100644 cil/src/testcil.ml delete mode 100644 cil/test/small1/func.c delete mode 100644 cil/test/small1/hello.c delete mode 100644 cil/test/small1/init.c delete mode 100644 cil/test/small1/init1.c delete mode 100644 cil/test/small1/testharness.h delete mode 100644 cil/test/small1/vararg1.c delete mode 100644 cil/test/small1/wchar1.c diff --git a/cfrontend/Cil2Csyntax.ml b/cfrontend/Cil2Csyntax.ml deleted file mode 100644 index 822f6cb..0000000 --- a/cfrontend/Cil2Csyntax.ml +++ /dev/null @@ -1,1283 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Thomas Moniot, INRIA Paris-Rocquencourt *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(************************************************************************** -CIL -> CabsCoq translator -**************************************************************************) - -open Cil -open Camlcoq -open AST -open Csyntax - -(* To associate CIL varinfo to the atoms representing global variables *) - -let varinfo_atom : (AST.ident, Cil.varinfo) Hashtbl.t = - Hashtbl.create 103 - -(** Functions used to handle locations *) - -let currentLocation = ref Cil.locUnknown - -(** Update the current location *) -let updateLoc loc = - currentLocation := loc - -(** Convert the current location into a string *) -let currentLoc() = - match !currentLocation with { line=l; file=f } -> - f ^ ":" ^ (if l = -1 then "?" else string_of_int l) ^ ": " - -(** Exception raised when an error in the C source is encountered, - e.g. unsupported C feature *) - -exception Error of string - -let error msg = - raise (Error(currentLoc() ^ msg)) - -let unsupported msg = - error ("Unsupported C feature: " ^ msg) - -let internal_error msg = - error ("Internal error: " ^ msg ^ "\nPlease report it.") - -(** Warning messages *) -let warning msg = - prerr_string (currentLoc()); - prerr_string "Warning: "; - prerr_endline msg - -(** Evaluate compile-time constant expressions. This is a more - aggressive variant of [Cil.constFold], which does not handle - floats. *) - -exception NotConst - -let mkint64 k v = - match Cil.kinteger64 k v with Const cst -> cst | _ -> assert false -let mkint k v = - mkint64 k (Int64.of_int v) -let mkfloat k v = - let v' = - match k with - | FFloat -> Int32.float_of_bits (Int32.bits_of_float v) - | _ -> v in - CReal(v', k, None) - -let bool_val = function - | CInt64(v, _, _) -> v <> 0L - | CReal(v, _, _) -> v <> 0.0 - | CStr s -> true - | CWStr s -> true - | _ -> assert false (* CChr, CEnum already expanded *) - -let rec eval_expr = function - | Const cst -> - eval_const cst - | SizeOf ty -> - (try mkint IUInt (bitsSizeOf ty / 8) - with SizeOfError _ -> raise NotConst) - | SizeOfE e -> - eval_expr (SizeOf (typeOf e)) - | SizeOfStr s -> - mkint IUInt (1 + String.length s) - | AlignOf ty -> - (try mkint IUInt (alignOf_int ty) - with SizeOfError _ -> raise NotConst) - | AlignOfE e -> - eval_expr (AlignOf (typeOf e)) - | UnOp(op, e, ty) -> - eval_unop op (eval_expr e) ty - | BinOp(op, e1, e2, ty) -> - eval_binop op (eval_expr e1) (eval_expr e2) ty - | CastE(ty, e) -> - eval_cast ty (eval_expr e) - | Lval lv -> raise NotConst - | AddrOf lv -> raise NotConst - | StartOf lv -> raise NotConst - -and eval_const = function - | CChr c -> charConstToInt c - | CEnum(e, _, _) -> eval_expr e - | cst -> cst - -and eval_unop op v ty = - match op, Cil.unrollType ty, v with - | Neg, TInt(ik, _), CInt64(v, _, _) -> mkint64 ik (Int64.neg v) - | Neg, TFloat(fk, _), CReal(v, _, _) -> mkfloat fk (-. v) - | BNot, TInt(ik, _), CInt64(v, _, _) -> mkint64 ik (Int64.logxor v (-1L)) - | LNot, TInt(ik, _), _ -> mkint ik (if bool_val v then 0 else 1) - | _, _, _ -> raise NotConst - -and eval_binop op v1 v2 ty = - match op, Cil.unrollType ty, v1, v2 with - | PlusA, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) -> - mkint64 ik (Int64.add v1 v2) - | PlusA, TFloat(fk, _), CReal(v1, _, _), CReal(v2, _, _) -> - mkfloat fk (v1 +. v2) - | MinusA, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) -> - mkint64 ik (Int64.sub v1 v2) - | MinusA, TFloat(fk, _), CReal(v1, _, _), CReal(v2, _, _) -> - mkfloat fk (v1 -. v2) - | Mult, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) -> - mkint64 ik (Int64.mul v1 v2) - | Mult, TFloat(fk, _), CReal(v1, _, _), CReal(v2, _, _) -> - mkfloat fk (v1 *. v2) - | Div, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) - when ik <> IULongLong && v2 != 0L -> - mkint64 ik (Int64.div v1 v2) - | Div, TFloat(fk, _), CReal(v1, _, _), CReal(v2, _, _) -> - mkfloat fk (v1 /. v2) - | Mod, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) - when ik <> IULongLong && v2 != 0L -> - mkint64 ik (Int64.rem v1 v2) - | Shiftlt, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) - when v2 >= 0L && v2 < 64L -> - mkint64 ik (Int64.shift_left v1 (Int64.to_int v2)) - | Shiftrt, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) - when v2 >= 0L && v2 < 64L -> - mkint64 ik (if isSigned ik - then Int64.shift_right v1 (Int64.to_int v2) - else Int64.shift_right_logical v1 (Int64.to_int v2)) - | Lt, _, _, _ -> eval_comparison (<) v1 v2 - | Gt, _, _, _ -> eval_comparison (>) v1 v2 - | Le, _, _, _ -> eval_comparison (<=) v1 v2 - | Ge, _, _, _ -> eval_comparison (>=) v1 v2 - | Eq, _, _, _ -> eval_comparison (=) v1 v2 - | Ne, _, _, _ -> eval_comparison (<>) v1 v2 - | BAnd, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) -> - mkint64 ik (Int64.logand v1 v2) - | BXor, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) -> - mkint64 ik (Int64.logxor v1 v2) - | BOr, TInt(ik, _), CInt64(v1, _, _), CInt64(v2, _, _) -> - mkint64 ik (Int64.logor v1 v2) - | LAnd, TInt(ik, _), _, _ -> - mkint ik (if bool_val v1 && bool_val v2 then 1 else 0) - | LOr, TInt(ik, _), _, _ -> - mkint ik (if bool_val v1 || bool_val v2 then 1 else 0) - | _, _, _, _ -> - raise NotConst - -and eval_comparison op v1 v2 = - let cmp = - match v1, v2 with - | CInt64(v1, ik1, _), CInt64(v2, ik2, _) -> - let shift v = Int64.sub v 0x8000_0000_0000_0000L in - if ik1 = IULongLong || ik2 = IULongLong - then compare (shift v1) (shift v2) - else compare v1 v2 - | CReal(v1, _, _), CReal(v2, _, _) -> - compare v1 v2 - | _, _ -> - raise NotConst - in mkint IInt (if op cmp 0 then 1 else 0) - -and eval_cast ty v = - match Cil.unrollType ty, v with - | TInt(ik, _), CInt64(v, _, _) -> mkint64 ik v - | TInt(ik, _), CReal(v, _, _) -> - if ik = IULongLong then raise NotConst else mkint64 ik (Int64.of_float v) - | TEnum _, CInt64(v, _, _) -> mkint64 IInt v - | TEnum _, CReal(v, _, _) -> mkint64 IInt (Int64.of_float v) - | TFloat(fk, _), CReal(v, _, _) -> mkfloat fk v - | TFloat(fk, _), CInt64(v, ik, _) -> - if ik = IULongLong then raise NotConst else mkfloat fk (Int64.to_float v) - | TPtr(_, _), CInt64(_, _, _) -> v (* tolerance? *) - | TPtr(_, _), CStr s -> v (* tolerance? *) - | TPtr(_, _), CWStr s -> v (* tolerance? *) - | _, _ -> raise NotConst - -(** Hooks -- overriden in machine-dependent CPragmas module *) - -let process_pragma_hook = ref (fun (a: Cil.attribute) -> false) -let define_variable_hook = ref (fun (id: ident) (v: Cil.varinfo) -> ()) -let define_function_hook = ref (fun (id: ident) (v: Cil.varinfo) -> ()) -let define_stringlit_hook = ref (fun (id: ident) (v: Cil.varinfo) -> ()) - -(** The parameter to the translation functor: it specifies the - translation for integer and float types. *) - -module type TypeSpecifierTranslator = - sig - val convertIkind: Cil.ikind -> (intsize * signedness) option - val convertFkind: Cil.fkind -> floatsize option - end - -module Make(TS: TypeSpecifierTranslator) = struct -(*-----------------------------------------------------------------------*) - - -(** Pre-defined constants *) -let constInt32 = Tint (I32, Signed) -let constInt32uns = Tint (I32, Unsigned) -let const0 = Expr (Econst_int (coqint_of_camlint Int32.zero), constInt32) - - -(** Global variables *) -let stringNum = ref 0 (* number of next global for string literals *) -let stringTable = Hashtbl.create 47 - -(** ** Functions related to [struct]s and [union]s *) - -(* Unroll recursion in struct or union types: - substitute [Tcomp_ptr id] by [Tpointer compty] in [ty]. *) - -let unrollType id compty ty = - let rec unrType ty = - match ty with - | Tvoid -> ty - | Tint(sz, sg) -> ty - | Tfloat sz -> ty - | Tpointer ty -> Tpointer (unrType ty) - | Tarray(ty, sz) -> Tarray (unrType ty, sz) - | Tfunction(args, res) -> Tfunction(unrTypelist args, unrType res) - | Tstruct(id', fld) -> - if id' = id then ty else Tstruct(id', unrFieldlist fld) - | Tunion(id', fld) -> - if id' = id then ty else Tunion(id', unrFieldlist fld) - | Tcomp_ptr id' -> - if id' = id then Tpointer compty else ty - and unrTypelist = function - | Tnil -> Tnil - | Tcons(hd, tl) -> Tcons(unrType hd, unrTypelist tl) - and unrFieldlist = function - | Fnil -> Fnil - | Fcons(id, ty, tl) -> Fcons(id, unrType ty, unrFieldlist tl) - in unrType ty - -(* Return the type of a [struct] field *) -let rec getFieldType f = function - | Fnil -> raise Not_found - | Fcons(idf, t, rem) -> if idf = f then t else getFieldType f rem - -(** ** Some functions over lists *) - -(** Keep the elements in a list from [elt] (included) to the end - (used for the translation of the [switch] statement) *) -let rec keepFrom elt = function - | [] -> [] - | (x :: l) as l' -> if x == elt then l' else keepFrom elt l - -(** Keep the elements in a list before [elt'] (excluded) - (used for the translation of the [switch] statement) *) -let rec keepUntil elt' = function - | [] -> [] - | x :: l -> if x == elt' then [] else x :: (keepUntil elt' l) - -(** Keep the elements in a list from [elt] (included) to [elt'] (excluded) - (used for the translation of the [switch] statement) *) -let keepBetween elt elt' l = - keepUntil elt' (keepFrom elt l) - -(** ** Functions used to handle string literals *) - -let name_for_string_literal s = - try - Hashtbl.find stringTable s - with Not_found -> - incr stringNum; - let name = Printf.sprintf "__stringlit_%d" !stringNum in - let id = intern_string name in - let v = - makeVarinfo true s (typeAddAttributes [Attr("const",[])] charPtrType) in - v.vstorage <- Static; - v.vreferenced <- true; - Hashtbl.add varinfo_atom id v; - !define_stringlit_hook id v; - Hashtbl.add stringTable s id; - id - -let typeStringLiteral s = - Tarray(Tint(I8, Unsigned), z_of_camlint(Int32.of_int(String.length s + 1))) - -let global_for_string s id = - let init = ref [] in - let add_char c = - init := - AST.Init_int8(coqint_of_camlint(Int32.of_int(Char.code c))) - :: !init in - add_char '\000'; - for i = String.length s - 1 downto 0 do add_char s.[i] done; - Datatypes.Coq_pair(Datatypes.Coq_pair(id, !init), typeStringLiteral s) - -let globals_for_strings globs = - Hashtbl.fold - (fun s id l -> global_for_string s id :: l) - stringTable globs - -(** ** Handling of stubs for variadic functions *) - -let stub_function_table = Hashtbl.create 47 - -let register_stub_function name tres targs = - let rec letters_of_type = function - | Tnil -> [] - | Tcons(Tfloat _, tl) -> "f" :: letters_of_type tl - | Tcons(_, tl) -> "i" :: letters_of_type tl in - let stub_name = - name ^ "$" ^ String.concat "" (letters_of_type targs) in - try - (stub_name, Hashtbl.find stub_function_table stub_name) - with Not_found -> - let rec types_of_types = function - | Tnil -> Tnil - | Tcons(Tfloat _, tl) -> Tcons(Tfloat F64, types_of_types tl) - | Tcons(_, tl) -> Tcons(Tpointer Tvoid, types_of_types tl) in - let stub_type = Tfunction (types_of_types targs, tres) in - Hashtbl.add stub_function_table stub_name stub_type; - (stub_name, stub_type) - -let declare_stub_function stub_name stub_type = - match stub_type with - | Tfunction(targs, tres) -> - Datatypes.Coq_pair(intern_string stub_name, - External(intern_string stub_name, targs, tres)) - | _ -> assert false - -let declare_stub_functions k = - Hashtbl.fold (fun n i k -> declare_stub_function n i :: k) - stub_function_table k - -(** ** Generation of temporary variable names *) - -let current_function = ref (None: Cil.fundec option) - -let make_temp typ = - match !current_function with - | None -> assert false - | Some f -> - let v = Cil.makeTempVar f typ in - intern_string v.vname - -let rec constant_address e = - match e with - | Expr(Evar v, _) -> true - | Expr(Efield(e, id), _) -> constant_address e - | _ -> false - -let cache_address ty e (f: expr -> statement) = - if constant_address e then - f e - else begin - let t = make_temp (TPtr(ty, [])) in - let ty = typeof e in - let typ = Tpointer ty in - Ssequence(Sassign(Expr(Evar t, typ), Expr(Eaddrof e, typ)), - f (Expr(Ederef(Expr(Evar t, typ)), ty))) - end - -let current_function_return_type() = - match !current_function with - | None -> assert false - | Some f -> - match f.svar.vtype with - | TFun(ty_ret, ty_args, _, _) -> ty_ret - | _ -> assert false - -(** Detect and report GCC's __builtin_ functions *) - -let check_builtin s = - let b = "__builtin_" in - if String.length s >= String.length b - && String.sub s 0 (String.length b) = b - then unsupported ("GCC `" ^ s ^ "' built-in function") - -(** ** Helpers for struct assignment *) - -let eintconst n = - Expr(Econst_int n, Tint(I32, Signed)) -let eindex e1 e2 ty = - Expr(Ederef(Expr (Ebinop(Oadd, e1, e2), typeof e1)), ty) -let eaddrof e = - Expr(Eaddrof e, Tpointer(typeof e)) - -let memcpy_ident = intern_string "memcpy" -let memcpy_arg_type = - Tcons(Tpointer Tvoid, Tcons(Tpointer Tvoid, Tcons(Tint(I32, Unsigned), Tnil))) -let memcpy_res_type = Tpointer Tvoid -let memcpy_type = Tfunction(memcpy_arg_type, memcpy_res_type) -let memcpy_used = ref false - -exception Use_memcpy - -let max_assignment_num = 8 - -let compile_assignment ty lhs rhs = - - let num_assign = ref 0 in - - let rec comp_assign l r = - match typeof l with - | Tstruct(id, flds) -> - let rec comp_field = function - | Fnil -> Sskip - | Fcons(id, ty, rem) -> - let ty = unrollType id (Tstruct(id, flds)) ty in - Ssequence(comp_assign (Expr (Efield(l, id), ty)) - (Expr (Efield(r, id), ty)), - comp_field rem) - in comp_field flds - | Tunion(id, flds) -> raise Use_memcpy - | Tarray(ty, sz) -> - let sz = camlint_of_coqint sz in - let rec comp_element i = - if i >= sz then Sskip else begin - let idx = eintconst (coqint_of_camlint i) in - Ssequence(comp_assign (eindex l idx ty) (eindex r idx ty), - comp_element (Int32.succ i)) - end - in comp_element 0l - | _ -> - if !num_assign >= max_assignment_num then raise Use_memcpy; - incr num_assign; - Sassign(l, r) - in - try - cache_address ty lhs (fun lhs' -> - cache_address ty rhs (fun rhs' -> - comp_assign lhs' rhs')) - with Use_memcpy -> - memcpy_used := true; - Scall(None, Expr(Evar memcpy_ident, memcpy_type), - [eaddrof lhs; eaddrof rhs; eintconst (sizeof (typeof lhs))]) - -let declare_memcpy fundecl = - if !memcpy_used - && not (List.exists (fun (Datatypes.Coq_pair(id, _)) -> id = memcpy_ident) - fundecl) - then Datatypes.Coq_pair(memcpy_ident, - External(memcpy_ident, memcpy_arg_type, memcpy_res_type)) - :: fundecl - else fundecl - -(** ** Translation functions *) - -(** Convert a [Cil.ikind] into a pair [(intsize * signedness)] *) -let convertIkind ik = - match TS.convertIkind ik with - | Some p -> p - | None -> unsupported "integer type specifier" - - -(** Convert a [Cil.fkind] into a [floatsize] *) -let convertFkind fk = - match TS.convertFkind fk with - | Some fs -> fs - | None -> unsupported "floating-point type specifier" - - -(** Convert a [Cil.constant] into a [CabsCoq.expr] *) -let rec convertConstant = function - | CInt64 (i64, _, _) -> - let i = coqint_of_camlint (Int64.to_int32 i64) in - Expr (Econst_int i, constInt32) - | CStr s -> - let symb = name_for_string_literal s in - Expr (Evar symb, typeStringLiteral s) - | CWStr _ -> - unsupported "wide string literal" - | CChr c -> - let i = coqint_of_camlint (Int32.of_int (Char.code c)) in - Expr (Econst_int i, constInt32) - | CReal (f, _, _) -> - Expr (Econst_float f, Tfloat F64) - | (CEnum (exp, str, enumInfo)) as enum -> - (* do constant folding on an enum constant *) - let e = Cil.constFold false (Const enum) in - convertExp e - - -(** Convert a [Cil.UnOp] into a [CabsCoq.expr] - ([t] is the type of the result of applying [uop] to [e]) *) -and convertUnop uop e t = - let e' = convertExp e in - let t' = convertTyp t in - let uop' = match uop with - | Neg -> Eunop (Oneg, e') - | BNot -> Eunop (Onotint, e') - | LNot -> Eunop (Onotbool, e') - in - Expr (uop', t') - - -(** Convert a [Cil.BinOp] into a [CabsCoq.expr] - ([t] is the type of the result of applying [bop] to [(e1, e2)], every - arithmetic conversion being made explicit by CIL for both arguments] *) -and convertBinop bop e1 e2 t = - let e1' = convertExp e1 in - let e2' = convertExp e2 in - let t' = convertTyp t in - let bop' = match bop with - | PlusA -> Ebinop (Oadd, e1', e2') - | PlusPI -> Ebinop (Oadd, e1', e2') - | IndexPI -> Ebinop (Oadd, e1', e2') - | MinusA -> Ebinop (Osub, e1', e2') - | MinusPI -> Ebinop (Osub, e1', e2') - | MinusPP -> Ebinop (Osub, e1', e2') - | Mult -> Ebinop (Omul, e1', e2') - | Div -> Ebinop (Odiv, e1', e2') - | Mod -> Ebinop (Omod, e1', e2') - | Shiftlt -> Ebinop (Oshl, e1', e2') - | Shiftrt -> Ebinop (Oshr, e1', e2') - | Lt -> Ebinop (Olt, e1', e2') - | Gt -> Ebinop (Ogt, e1', e2') - | Le -> Ebinop (Ole, e1', e2') - | Ge -> Ebinop (Oge, e1', e2') - | Eq -> Ebinop (Oeq, e1', e2') - | Ne -> Ebinop (One, e1', e2') - | BAnd -> Ebinop (Oand, e1', e2') - | BXor -> Ebinop (Oxor, e1', e2') - | BOr -> Ebinop (Oor, e1', e2') - | LAnd -> Eandbool (e1', e2') - | LOr -> Eorbool (e1', e2') - in - Expr (bop', t') - - -(** Test if two types are compatible - (in order to cast one of the types to the other) *) -and compatibleTypes t1 t2 = true -(* - let isArithmeticType = function - | Tint _ | Tfloat _ -> true - | _ -> false - in - let isPointerType = function - | Tpointer _ | Tarray _ -> true - | _ -> false - in - (t1 = t2) - || (isArithmeticType t1 && isArithmeticType t2) - || match (t1, t2) with - | (Tpointer Tvoid, t) | (t, Tpointer Tvoid) -> isPointerType t - | (Tint _, t) | (t, Tint _) -> isPointerType t - | _ -> false -*) - - -(** Convert a [Cil.CastE] into a [CabsCoq.expr] - (fail if the cast is illegal) *) -and processCast t e = - let t' = convertTyp t in - let te = convertTyp (Cil.typeOf e) in - if compatibleTypes t' te then - let e' = convertExp e in - Expr (Ecast (t', e'), t') - else internal_error "processCast: illegal cast" - - -(** Convert a [Cil.exp list] into an [CamlCoq.exprlist] *) -and processParamsE = function - | [] -> [] - | e :: l -> - let (Expr (_, t)) as e' = convertExp e in - match t with - | Tstruct _ | Tunion _ -> - unsupported "function parameter of struct or union type" - | _ -> e' :: processParamsE l - - -(** Convert a [Cil.exp] into a [CabsCoq.expr] *) -and convertExp = function - | Const c -> - convertConstant c - | Lval lv -> - convertLval lv - | SizeOf t -> - Expr (Esizeof (convertTyp t), constInt32uns) - | SizeOfE e -> - let ty = convertTyp (Cil.typeOf e) in - Expr (Esizeof ty, constInt32uns) - | SizeOfStr str -> - let n = coqint_of_camlint (Int32.of_int(String.length str)) in - Expr (Econst_int n, constInt32uns) - | AlignOf t -> - unsupported "GCC `alignof' construct" - | AlignOfE e -> - unsupported "GCC `alignof' construct" - | UnOp (uop, e, t) -> - convertUnop uop e t - | BinOp (bop, e1, e2, t) -> - convertBinop bop e1 e2 t - | CastE (t, e) -> - processCast t e - | AddrOf lv -> - let (Expr (_, t)) as e = convertLval lv in - Expr (Eaddrof e, Tpointer t) - | StartOf lv -> - (* convert an array into a pointer to the beginning of the array *) - match Cil.unrollType (Cil.typeOfLval lv) with - | TArray (t, _, _) -> - let t' = convertTyp t in - let tPtr = Tpointer t' in - let e = convertLval lv in - (* array A of type T replaced by (T* )A *) - Expr (Ecast (tPtr, e), tPtr) - | _ -> internal_error "convertExp: StartOf applied to a \ - lvalue whose type is not an array" - - -(** Convert a [Cil.lval] into a [CabsCoq.expression] *) -and convertLval lv = - (* convert the offset of the lvalue *) - let rec processOffset ((Expr (_, t)) as e) = function - | NoOffset -> e - | Field (f, ofs) -> - begin match t with - | Tstruct(id, fList) -> - begin try - let idf = intern_string f.fname in - let t' = unrollType id t (getFieldType idf fList) in - processOffset (Expr (Efield (e, idf), t')) ofs - with Not_found -> - internal_error "processOffset: no such struct field" - end - | Tunion(id, fList) -> - begin try - let idf = intern_string f.fname in - let t' = unrollType id t (getFieldType idf fList) in - processOffset (Expr (Efield (e, idf), t')) ofs - with Not_found -> - internal_error "processOffset: no such union field" - end - | _ -> - internal_error "processOffset: Field on a non-struct nor union" - end - | Index (e', ofs) -> - match t with - | Tarray (t', _) -> - let e'' = Ederef(Expr (Ebinop(Oadd, e, convertExp e'), t)) in - processOffset (Expr (e'', t')) ofs - | _ -> internal_error "processOffset: Index on a non-array" - in - (* convert the lvalue *) - match lv with - | (Var v, ofs) -> - check_builtin v.vname; - let id = intern_string v.vname in - processOffset (Expr (Evar id, convertTyp v.vtype)) ofs - | (Mem e, ofs) -> - match Cil.unrollType (Cil.typeOf e) with - | TPtr (t, _) -> let e' = Ederef (convertExp e) in - processOffset (Expr (e', convertTyp t)) ofs - | _ -> internal_error "convertLval: Mem on a non-pointer" - - -(** Convert a [(Cil.string * Cil.typ * Cil.attributes)] list - into a [typelist] *) -and processParamsT convert = function - | [] -> Tnil - | (_, t, _) :: l -> - let t' = convert t in - match t' with - | Tstruct _ | Tunion _ -> - unsupported "function parameter of struct or union type" - | _ -> Tcons (t', processParamsT convert l) - - -(** Convert a [Cil.typ] into a [coq_type] *) -and convertTypGen env = function - | TVoid _ -> Tvoid - | TInt (k, _) -> let (x, y) = convertIkind k in Tint (x, y) - | TFloat (k, _) -> Tfloat (convertFkind k) - | TPtr (TComp(c, _), _) when List.mem c.ckey env -> - Tcomp_ptr (intern_string (Cil.compFullName c)) - | TPtr (t, _) -> Tpointer (convertTypGen env t) - | TArray (t, eOpt, _) -> - begin match eOpt with - | None -> - warning "array type of unspecified size"; - Tarray (convertTypGen env t, coqint_of_camlint 0l) - | Some e -> - begin try - match eval_expr e with - | CInt64 (i64, _, _) -> - Tarray (convertTypGen env t, - coqint_of_camlint (Int64.to_int32 i64)) - | _ -> unsupported "size of array type not an integer constant" - with NotConst -> - unsupported "size of array type not constant" - end - end - | TFun (t, argListOpt, vArg, _) -> - if vArg then unsupported "variadic function type"; - let argList = - match argListOpt with - | None -> unsupported "un-prototyped function type" - | Some l -> l - in - let t' = convertTypGen env t in - begin match t' with - | Tstruct _ | Tunion _ -> - unsupported "return type is a struct or union" - | _ -> Tfunction (processParamsT (convertTypGen env) argList, t') - end - | TNamed (tinfo, _) -> convertTypGen env tinfo.ttype - | TComp (c, _) -> - let rec convertFieldList = function - | [] -> Fnil - | {fname=str; ftype=t} :: rem -> - let idf = intern_string str in - let t' = convertTypGen (c.ckey :: env) t in - Fcons(idf, t', convertFieldList rem) in - let fList = convertFieldList c.cfields in - let id = intern_string (Cil.compFullName c) in - if c.cstruct then Tstruct(id, fList) else Tunion(id, fList) - | TEnum _ -> constInt32 (* enum constants are integers *) - | TBuiltin_va_list _ -> unsupported "GCC `builtin va_list' type" - -and convertTyp ty = convertTypGen [] ty - -(** Convert a [Cil.varinfo] into a pair [(ident * coq_type)] *) -let convertVarinfo v = - updateLoc(v.vdecl); - let id = intern_string v.vname in - Datatypes.Coq_pair (id, convertTyp v.vtype) - - -(** Convert a [Cil.varinfo] into a pair [(ident * coq_type)] - (fail if the variable is of type struct or union) *) -let convertVarinfoParam v = - updateLoc(v.vdecl); - let id = intern_string v.vname in - let t' = convertTyp v.vtype in - match t' with - | Tstruct _ | Tunion _ -> - unsupported "function parameter of struct or union type" - | _ -> Datatypes.Coq_pair (id, t') - - -(** Convert a [Cil.exp] which has a function type into a [CabsCoq.expr] - (used only to translate function calls) *) -let convertExpFuncall e eList = - match typeOf e with - | TFun (res, argListOpt, vArg, _) -> - begin match argListOpt, vArg with - | Some argList, false -> - (* Prototyped, non-variadic function *) - if List.length argList <> List.length eList then - internal_error "convertExpFuncall: wrong number of arguments"; - (convertExp e, processParamsE eList) - | _, _ -> - (* Variadic or unprototyped function: generate a call to - a stub function with the appropriate number and types - of arguments. Works only if the function expression e - is a global variable. *) - let params = processParamsE eList in - let fun_name = - match e with - | Lval(Var v, NoOffset) -> - warning "working around a call to a variadic function"; - v.vname - | _ -> - unsupported "call to variadic function" in - let rec typeOfExprList = function - | [] -> Tnil - | Expr (_, ty) :: rem -> Tcons (ty, typeOfExprList rem) in - let targs = typeOfExprList params in - let tres = convertTyp res in - let (stub_fun_name, stub_fun_typ) = - register_stub_function fun_name tres targs in - (Expr(Evar(intern_string stub_fun_name), stub_fun_typ), - params) - end - | _ -> internal_error "convertExpFuncall: not a function" - -(** Auxiliaries for function calls *) - -let makeFuncall1 tyfun (Expr(_, tlhs) as elhs) efun eargs = - match tyfun with - | TFun (t, _, _, _) -> - let tres = convertTyp t in - if tlhs = tres then - Scall(Some elhs, efun, eargs) - else begin - let tmp = make_temp t in - let elhs' = Expr(Evar tmp, tres) in - Ssequence(Scall(Some elhs', efun, eargs), - Sassign(elhs, Expr(Ecast(tlhs, elhs'), tlhs))) - end - | _ -> internal_error "wrong type for function in call" - -let makeFuncall2 tyfun tylhs elhs efun eargs = - match elhs with - | Expr(Evar _, _) -> - makeFuncall1 tyfun elhs efun eargs - | Expr(_, tlhs) -> - let tmp = make_temp tylhs in - let elhs' = Expr(Evar tmp, tlhs) in - Ssequence(makeFuncall1 tyfun elhs' efun eargs, - Sassign(elhs, elhs')) - -(** Convert a [Cil.instr] into a [CabsCoq.statement] *) -let processInstr = function - | Set (lv, rv, loc) -> - updateLoc(loc); - let lv' = convertLval lv in - let rv' = convertExp rv in - begin match typeof lv' with - | Tstruct _ | Tunion _ -> compile_assignment (typeOfLval lv) lv' rv' - | t -> Sassign (lv', rv') - end - | Call (None, e, eList, loc) -> - updateLoc(loc); - let (efun, params) = convertExpFuncall e eList in - Scall(None, efun, params) - | Call (Some lv, e, eList, loc) -> - updateLoc(loc); - let (efun, params) = convertExpFuncall e eList in - makeFuncall2 (Cil.typeOf e) (Cil.typeOfLval lv) (convertLval lv) efun params - | Asm (_, _, _, _, _, loc) -> - updateLoc(loc); - unsupported "inline assembly" - -(** Convert a [Cil.instr list] into a [CabsCoq.statement] *) - -let rec processInstrList = function - | [] -> Sskip - | [s] -> processInstr s - | s :: l -> - let cs = processInstr s in - let cl = processInstrList l in - Ssequence (cs, cl) - - -(** Convert a [Cil.stmt list] into a [CabsCoq.statement] *) -let rec processStmtList = function - | [] -> Sskip - | [s] -> convertStmt s - | s :: l -> - let cs = convertStmt s in - let cl = processStmtList l in - Ssequence (cs, cl) - - -(** Return the list of the constant expressions in a label list - (return [None] if this is the default case) - (fail if the constant expression is not of type integer) *) -and getCaseList lblList = - match lblList with - | [] -> Some [] - | Label (_, loc, _) :: l -> updateLoc(loc); getCaseList l - | Default loc :: _ -> updateLoc(loc); None - | Case (e, loc) :: l -> - updateLoc(loc); - begin match convertExp e with - | Expr (Econst_int n, _) -> - begin match getCaseList l with - | None -> None - | Some cl -> Some (n :: cl) - end - | _ -> internal_error "getCaseList: case label does not \ - reduce to an integer constant" - end - - -(** Convert a list of integers into a [CabsCoq.lblStatementList] *) -and processCaseList cl s lrem = - match cl with - | [] -> internal_error "processCaseList: syntax error in switch statement" - | [n] -> LScase (n, s, lrem) - | n1 :: l -> LScase (n1, Sskip, processCaseList l s lrem) - - -(** Convert a [Cil.stmt list] which is the body of a Switch structure - into a [CabsCoq.lblStatementList] - (Pre-condition: all the Case labels are supposed to be at the same level, - ie. no nested structures) *) -and processLblStmtList switchBody = function - | [] -> LSdefault Sskip - | [ls] -> - let s = processStmtList (keepFrom ls switchBody) in - begin match getCaseList ls.labels with - | None -> LSdefault s - | Some cl -> processCaseList cl s (LSdefault Sskip) - end - | ls :: ((ls' :: _) as l) -> - if ls.labels = ls'.labels then processLblStmtList switchBody l - else - begin match getCaseList ls.labels with - | None -> unsupported "default case is not at the end of this `switch' statement" - | Some cl -> - let s = processStmtList (keepBetween ls ls' switchBody) in - let lrem = processLblStmtList switchBody l in - processCaseList cl s lrem - end - - -(** Convert a [Cil.stmtkind] into a [CabsCoq.statement] *) -and convertStmtKind = function - | Instr iList -> - processInstrList iList - | Return (eOpt, loc) -> - updateLoc(loc); - let ty_ret = current_function_return_type() in - let eOpt' = match eOpt with - | None -> - if isVoidType ty_ret - then None - else unsupported ("`return' without a value in function with non-void return type") - | Some e -> - if isVoidType ty_ret - then unsupported ("`return' with a value in function returning void") - else Some (convertExp e) - in - Sreturn eOpt' - | Goto (sref, loc) -> - updateLoc(loc); - let rec extract_label = function - | [] -> internal_error "convertStmtKind: goto without label" - | Label(lbl, _, _) :: _ -> lbl - | _ :: rem -> extract_label rem - in - Sgoto (intern_string (extract_label (!sref).labels)) - | Break loc -> - updateLoc(loc); - Sbreak - | Continue loc -> - updateLoc(loc); - Scontinue - | If (e, b1, b2, loc) -> - updateLoc(loc); - let e1 = processStmtList b1.bstmts in - let e2 = processStmtList b2.bstmts in - Sifthenelse (convertExp e, e1, e2) - | Switch (e, b, l, loc) -> - updateLoc(loc); - Sswitch (convertExp e, processLblStmtList b.bstmts l) - | While (e, b, loc) -> - updateLoc(loc); - Swhile (convertExp e, processStmtList b.bstmts) - | DoWhile (e, b, loc) -> - updateLoc(loc); - Sdowhile (convertExp e, processStmtList b.bstmts) - | For (bInit, e, bIter, b, loc) -> - updateLoc(loc); - let sInit = processStmtList bInit.bstmts in - let e' = convertExp e in - let sIter = processStmtList bIter.bstmts in - Sfor (sInit, e', sIter, processStmtList b.bstmts) - | Block b -> processStmtList b.bstmts - | TryFinally (_, _, loc) -> - updateLoc(loc); - unsupported "`try'...`finally' statement" - | TryExcept (_, _, _, loc) -> - updateLoc(loc); - unsupported "`try'...`except' statement" - -(** Convert a [Cil.stmtkind] into a [CabsCoq.statement] *) -and convertStmt s = - let rec add_labels l s = - match l with - | [] -> s - | Label(lbl, _, _) :: rem -> Slabel(intern_string lbl, add_labels rem s) - | _ :: rem -> add_labels rem s (* error? *) - in add_labels s.labels (convertStmtKind s.skind) - -(** Convert a [Cil.GFun] into a pair [(ident * coq_fundecl)] *) -let convertGFun fdec = - current_function := Some fdec; - let v = fdec.svar in - let ret = match v.vtype with - | TFun (t, _, vArg, _) -> - if vArg then unsupported "variadic function"; - begin match convertTyp t with - | Tstruct _ | Tunion _ -> - unsupported "return value of struct or union type" - | t' -> t' - end - | _ -> internal_error "convertGFun: incorrect function type" - in - let s = processStmtList fdec.sbody.bstmts in (* function body -- do it first because of generated temps *) - let args = List.map convertVarinfoParam fdec.sformals in (* parameters*) - let varList = List.map convertVarinfo fdec.slocals in (* local vars *) - if v.vname = "main" then begin - match ret with - | Tint(_, _) -> () - | _ -> updateLoc v.vdecl; - unsupported "the return type of main() must be an integer type" - end; - current_function := None; - let id = intern_string v.vname in - Hashtbl.add varinfo_atom id v; - !define_function_hook id v; - Datatypes.Coq_pair - (id, - Internal { fn_return=ret; fn_params=args; fn_vars=varList; fn_body=s }) - -(** Auxiliary for [convertInit] *) - -let rec initDataLen accu = function - | [] -> accu - | i1 :: il -> - let sz = match i1 with - | Init_int8 _ -> 1l - | Init_int16 _ -> 2l - | Init_int32 _ -> 4l - | Init_float32 _ -> 4l - | Init_float64 _ -> 8l - | Init_space n -> camlint_of_z n - | Init_addrof(_, _) -> 4l - | Init_pointer _ -> 4l in - initDataLen (Int32.add sz accu) il - -(** Convert a [Cil.init] into a list of [AST.init_data] prepended to - the given list [k]. Result is in reverse order. *) - -type init_constant = - | ICint of int64 * intsize - | ICfloat of float * floatsize - | ICstring of string - | ICaddrof of string - | ICnone - -let extract_constant e = - match e with - | AddrOf(Var v, NoOffset) -> ICaddrof v.vname - | StartOf(Var v, NoOffset) -> ICaddrof v.vname - | _ -> - try - match eval_expr e with - | CInt64(n, ikind, _) -> ICint(n, fst (convertIkind ikind)) - | CReal(n, fkind, _) -> ICfloat(n, convertFkind fkind) - | CStr s -> ICstring s - | _ -> ICnone - with NotConst -> ICnone - -let init_data_of_string s = - let id = ref [] in - let enter_char c = - let n = coqint_of_camlint(Int32.of_int(Char.code c)) in - id := Init_int8 n :: !id in - enter_char '\000'; - for i = String.length s - 1 downto 0 do enter_char s.[i] done; - !id - -let convertInit init = - let k = ref [] - and pos = ref 0 in - let emit size datum = - k := datum :: !k; - pos := !pos + size in - let emit_space size = - emit size (Init_space (z_of_camlint (Int32.of_int size))) in - let check_align size = - assert (!pos land (size - 1) = 0) in - let align size = - let n = !pos land (size - 1) in - if n > 0 then emit_space (size - n) in - - let rec cvtInit init = - match init with - | SingleInit e -> - begin match extract_constant(Cil.constFold true e) with - | ICint(n, I8) -> - let n' = coqint_of_camlint (Int64.to_int32 n) in - emit 1 (Init_int8 n') - | ICint(n, I16) -> - check_align 2; - let n' = coqint_of_camlint (Int64.to_int32 n) in - emit 2 (Init_int16 n') - | ICint(n, I32) -> - check_align 4; - let n' = coqint_of_camlint (Int64.to_int32 n) in - emit 4 (Init_int32 n') - | ICfloat(n, F32) -> - check_align 4; - emit 4 (Init_float32 n) - | ICfloat(n, F64) -> - check_align 8; - emit 8 (Init_float64 n) - | ICaddrof id -> - check_align 4; - emit 4 (Init_addrof(intern_string id, coqint_of_camlint 0l)) - | ICstring s -> - check_align 4; - emit 4 (Init_pointer(init_data_of_string s)) - | ICnone -> - unsupported "this kind of expression is not supported in global initializers" - end - | CompoundInit(ty, data) -> - let ty' = convertTyp ty in - let sz = Int32.to_int (camlint_of_z (Csyntax.sizeof ty')) in - let pos0 = !pos in - Cil.foldLeftCompoundAll - ~doinit: cvtCompoundInit - ~ct: ty - ~initl: data - ~acc: (); - let pos1 = !pos in - assert (pos1 <= pos0 + sz); - if pos1 < pos0 + sz then emit_space (pos0 + sz - pos1) - - and cvtCompoundInit ofs init ty () = - let ty' = convertTyp ty in - let al = Int32.to_int (camlint_of_z (Csyntax.alignof ty')) in - align al; - cvtInit init - - in cvtInit init; List.rev !k - -(** Convert a [Cil.initinfo] into a list of [AST.init_data] *) - -let convertInitInfo ty info = - match info.init with - | None -> - [ Init_space(Csyntax.sizeof (convertTyp ty)) ] - | Some init -> - convertInit init - -(** Convert a [Cil.GVar] into a global variable definition *) - -let convertGVar v i = - updateLoc(v.vdecl); - let id = intern_string v.vname in - Hashtbl.add varinfo_atom id v; - !define_variable_hook id v; - Datatypes.Coq_pair (Datatypes.Coq_pair(id, convertInitInfo v.vtype i), - convertTyp v.vtype) - - -(** Convert a [Cil.GVarDecl] into a global variable declaration *) - -let convertExtVar v = - updateLoc(v.vdecl); - let id = intern_string v.vname in - Hashtbl.add varinfo_atom id v; - Datatypes.Coq_pair (Datatypes.Coq_pair(id, []), - convertTyp v.vtype) - -(** Convert a [Cil.GVarDecl] into an external function declaration *) - -let convertExtFun v = - updateLoc(v.vdecl); - match convertTyp v.vtype with - | Tfunction(args, res) -> - let id = intern_string v.vname in - Hashtbl.add varinfo_atom id v; - Datatypes.Coq_pair (id, External(id, args, res)) - | _ -> - assert false - -(** Convert a [Cil.global list] into a pair whose first component, - of type [(ident * coq_function) coqlist], represents the definitions of the - functions and the second component, of type [(ident * coq_type) coqlist], - the definitions of the global variables of the program *) -let rec processGlobals = function - | [] -> ([], []) - | g :: l -> - match g with - | GType _ -> processGlobals l (* typedefs are unrolled... *) - | GCompTag _ -> processGlobals l - | GCompTagDecl _ -> processGlobals l - | GEnumTag _ -> processGlobals l (* enum constants are folded... *) - | GEnumTagDecl _ -> processGlobals l - | GVarDecl (v, loc) -> - updateLoc(loc); - (* Functions become external declarations, - variadic and unprototyped functions are skipped, - variables become uninitialized variables *) - begin match Cil.unrollType v.vtype with - | TFun (tres, Some targs, false, _) -> - let fn = convertExtFun v in - let (fList, vList) = processGlobals l in - (fn :: fList, vList) - | TFun (tres, _, _, _) -> - processGlobals l - | _ -> - let var = convertExtVar v in - let (fList, vList) = processGlobals l in - (fList, var :: vList) - end - | GVar (v, init, loc) -> - updateLoc(loc); - let var = convertGVar v init in - let (fList, vList) = processGlobals l in - (fList, var :: vList) - | GFun (fdec, loc) -> - updateLoc(loc); - let fn = convertGFun fdec in - let (fList, vList) = processGlobals l in - (fn :: fList, vList) - | GAsm (_, loc) -> - updateLoc(loc); - unsupported "inline assembly" - | GPragma (Attr(name, _) as attr, loc) -> - updateLoc(loc); - if not (!process_pragma_hook attr) then - warning ("#pragma `" ^ name ^ "' directive ignored"); - processGlobals l - | GText _ -> processGlobals l (* comments are ignored *) - -(** Eliminate forward declarations of globals that are defined later *) - -let cleanupGlobals globs = - let defined = - List.fold_right - (fun g def -> - match g with GVar (v, init, loc) -> v.vname :: def - | GFun (fdec, loc) -> fdec.svar.vname :: def - | _ -> def) - globs [] in - List.filter - (function GVarDecl(v, loc) -> not(List.mem v.vname defined) - | g -> true) - globs - -(** Convert a [Cil.file] into a [CabsCoq.program] *) -let convertFile f = - stringNum := 0; - Hashtbl.clear varinfo_atom; - Hashtbl.clear stringTable; - Hashtbl.clear stub_function_table; - memcpy_used := false; - let (funList, defList) = processGlobals (cleanupGlobals f.globals) in - let funList1 = declare_stub_functions funList in - let funList2 = match f.globinit with - | Some fdec -> convertGFun fdec :: funList1 - | None -> funList1 in - let funList3 = declare_memcpy funList2 in - let defList1 = globals_for_strings defList in - { AST.prog_funct = funList3; - AST.prog_vars = defList1; - AST.prog_main = intern_string "main" } - -(*-----------------------------------------------------------------------*) -end - -(* Extracting information about global variables from their atom *) - -let atom_is_static a = - try - let v = Hashtbl.find varinfo_atom a in - v.vstorage = Static - with Not_found -> - false - -let var_is_readonly v = - let a = typeAttrs v.vtype in - if hasAttribute "volatile" a then false else - if hasAttribute "const" a then true else - match Cil.unrollType v.vtype with - | TArray(ty, _, _) -> - let a' = typeAttrs ty in - hasAttribute "const" a' && not (hasAttribute "volatile" a') - | _ -> false - -let atom_is_readonly a = - try var_is_readonly (Hashtbl.find varinfo_atom a) - with Not_found -> false diff --git a/cil/INSTALL b/cil/INSTALL deleted file mode 100644 index ef7846f..0000000 --- a/cil/INSTALL +++ /dev/null @@ -1,41 +0,0 @@ - - (For more complete installation instructions see the documentation in - doc/html.) - - Building from source (see below for installing binary distributions) ---------------------------------------------------------------------- - - 1. If you use Windows, you must first install cygwin. - - 2. You must install OCaml version 3.08 or higher (see instructions at - http://caml.inria.fr/ocaml). The recommended build process is using - the cygwin version of ocaml. - - You can also build with Microsoft Visual Studio, but you must still have - cygwin during the build process. See msvcbuild.cmd. - - 3. Download and unpack the distribution. - - 4. Run ./configure (from within bash if on Windows) - - 5. Run make - - 6. Run make check - - Now you can start using bin/cilly and bin/ccured as explained in the - documentation (in doc/html). - - - Installing binary distributions (Windows-only) ------------------------------------------------ - - 1. Unpack the installation package - - 2. Change CILHOME to the full path of the diretory where you put cil, in - the following files: bin/CilConfig.pm, bin/cilly.bat, bin/patcher.bat - 3. Go to test/small1 directory and run - ..\..\cilly /c hello.c - - - - \ No newline at end of file diff --git a/cil/LICENSE b/cil/LICENSE deleted file mode 100644 index 5a7dab5..0000000 --- a/cil/LICENSE +++ /dev/null @@ -1,35 +0,0 @@ -Copyright (c) 2001-2005, - George C. Necula - Scott McPeak - Wes Weimer - Ben Liblit -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -3. The names of the contributors may not be used to endorse or promote -products derived from this software without specific prior written -permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - - -(See http://www.opensource.org/licenses/bsd-license.php) diff --git a/cil/Makefile.gcc b/cil/Makefile.gcc deleted file mode 100644 index 8fae4e3..0000000 --- a/cil/Makefile.gcc +++ /dev/null @@ -1,75 +0,0 @@ -# -*-makefile-*- -# Makefile for CCured. The gcc part - - -COMPILERNAME := GNUCC - -CC := gcc -ifdef RELEASELIB - # sm: I will leave this here, but only use it for compiling our runtime lib - CFLAGS := -D_GNUCC -Wall -O3 -else - CFLAGS := -D_GNUCC -Wall -g -ggdb -D_DEBUG -endif - -# dsw: added optional -pg flag -ifdef USE_PG - CFLAGS += -pg -endif - -ifdef NO_OPTIMIZATION - OPT_O2 := -else - OPT_O2 := -O2 -endif -CONLY := -c -OBJOUT := -o -OBJEXT := o -LIBEXT := a -EXEOUT := -o -LDEXT := -DEF := -D -ASMONLY := -S -o -WARNALL := -Wall -# sm: shuffled around a couple things so I could use CPPSTART for patch2 -CPPSTART := gcc -E -x c -Dx86_LINUX -D_GNUCC -I/usr/include/sys -CPPOUT := -o %o -CPP := $(CPPSTART) -include fixup.h %i $(CPPOUT) -INC := -I - -# sm: disable patching for now ('true' has no output) -# (set it to 'echo' to re-enable) -ifndef PATCHECHO - PATCHECHO := echo -endif - -AR := ar -LIBOUT := -rs - -# The system include files to be patched -PATCH_SYSINCLUDES := crypt.h ctype.h fcntl.h glob.h grp.h malloc.h netdb.h \ - pthread.h pwd.h signal.h stdarg.h stdio.h stdlib.h \ - string.h time.h unistd.h varargs.h arpa/inet.h \ - sys/cdefs.h sys/fcntl.h sys/ioctl.h sys/socket.h \ - sys/stat.h sys/types.h sys/uio.h malloc.h setjmp.h - -ifneq ($(ARCHOS), x86_WIN32) -PATCH_SYSINCLUDES += sys/shm.h -endif - -# dsw & sm: DON'T DO THIS. See comment in ccured_GNUCC.patch, search for 'sys/io.h'. -# PATCH_SYSINCLUDES += sys/io.h - -# matth: reent.h is only in Cygwin, and Cygwin defines struct sigaction -# in sys/signal.h: -ifeq ($(ARCHOS), x86_WIN32) -PATCH_SYSINCLUDES += sys/reent.h sys/signal.h -endif - -# matth: these files are not in Cygwin -ifeq ($(ARCHOS), x86_LINUX) -PATCH_SYSINCLUDES += nl_types.h bits/sigaction.h bits/select.h sys/prctl.h \ - libgen.h shadow.h -endif - - diff --git a/cil/Makefile.in b/cil/Makefile.in deleted file mode 100644 index a16d60c..0000000 --- a/cil/Makefile.in +++ /dev/null @@ -1,656 +0,0 @@ -# -*- Mode: makefile -*- - -# Makefile for the cil wrapper -# @do_not_edit@ Makefile.in -# -# author: George Necula - -# -# If you want to add extra CIL features, you do not always need to change -# this file. Just invoke -# ./configure EXTRASRCDIRS=/home/foodir EXTRAFEATURES="foo bar" -# This will add two features that must be defined in foo.ml and bar.ml -# - -# Debugging. Set ECHO= to debug this Makefile -.PHONY: setup quickbuild doc distrib machdep cilversion -ECHO = @ - -# It is important to build quickbuild first, to generate the proper dependencies -all: quickbuild setup - -# Now add the defines for the CIL features -@CIL_FEATURES_DEFINES@ - - -# look out for outdated Makefile; if it's out of date, this will automatically -# re-run ./config.status, then re-exec make with the same arguments -Makefile: config.status Makefile.in - ./$< - -config.status: configure - ./$@ --recheck - -configure: configure.in - autoconf - -ocamlutil/perfcount.c: config.status ocamlutil/perfcount.c.in - ./$< - -@DEFAULT_COMPILER@=1 - - - -ifdef RELEASE - NATIVECAML := 1 - UNSAFE := 1 -endif - -ifndef ARCHOS - ARCHOS=@ARCHOS@ -endif - -# Put here all the byproducts of make -OBJDIR := obj/$(ARCHOS) -DEPENDDIR := obj/.depend - -CILLY_FEATURES := -ifdef USE_BLOCKINGGRAPH - CILLY_FEATURES += blockinggraph -endif -ifdef USE_RAND - CILLY_FEATURES += rand -endif -ifdef USE_ARITHABS - CILLY_FEATURES += arithabs -endif -ifdef USE_SMALLOC - CILLY_FEATURES += smalloc -endif -ifdef USE_CQUALANN - CILLY_FEATURES += cqualann -endif -ifdef USE_ZRAPP - CILLY_FEATURES += rmciltmps zrapp -endif -# Add the EXTRAFEATURES -CILLY_FEATURES += @EXTRAFEATURES@ - - # Now rules to make cilly -CILLY_LIBRARY_MODULES = pretty inthash errormsg alpha trace stats util clist \ - cilutil escape growArray\ - cabs cabsvisit cprint lexerhack machdep cparser clexer \ - cilversion cil cillower formatparse formatlex formatcil cabs2cil \ - patch frontc check mergecil \ - dataflow dominators bitmap ssa ciltools \ - usedef logcalls logwrites rmtmps \ - callgraph epicenter heapify \ - setp uref olf ptranal \ - canonicalize heap oneret partial simplemem simplify \ - dataslicing sfi \ - cfg reachingdefs deadcodeelim availexps \ - liveness \ - testcil \ - $(CILLY_FEATURES) \ - ciloptions feature_config -# ww: we don't want "main" in an external cil library (cil.cma), -# otherwise every program that links against that library will get -# main's argument checking and whatnot ... -CILLY_MODULES = $(CILLY_LIBRARY_MODULES) main -CILLY_CMODULES = -CILLY_LIBS = unix str - -SOURCEDIRS += src src/frontc src/ext src/ext/pta ocamlutil @EXTRASRCDIRS@ -MLLS += clexer.mll formatlex.mll -MLYS += cparser.mly formatparse.mly -MODULES += $(CILLY_MODULES) libmaincil - - - - # Include now the common set of rules for OCAML -include ocamlutil/Makefile.ocaml - - - # Now the rule to make cilly - -PROJECT_EXECUTABLE = $(OBJDIR)/cilly$(EXE) -PROJECT_MODULES = $(CILLY_MODULES) -PROJECT_CMODULES = perfcount $(CILLY_CMODULES) -PROJECT_LIBS = $(CILLY_LIBS) -cilly: $(PROJECT_EXECUTABLE) -include ocamlutil/Makefile.ocaml.build - - -quickbuild: cilversion machdep cilly - -# Setup also makes the native code versions -# -# sm: cillib is only built with NATIVECAML=1 because it builds libcil.a, -# which requires native-code .cmx compiled modules... could break it -# into two targets so we build cil.cma both ways, but no one is using -# cil.cma now so I'll leave it alone -setup: cilversion machdep - $(MAKE) cilly NATIVECAML= - $(MAKE) cilly NATIVECAML=1 - $(MAKE) cillib NATIVECAML= - $(MAKE) cillib NATIVECAML=1 - -# Create the machine dependency module -# If the cl command cannot be run then the MSVC part will be identical to GCC -.PHONY : machdep -machdep: $(OBJDIR)/machdep.ml -$(OBJDIR)/machdep.ml : src/machdep.c configure.in Makefile.in - rm -f $@ - echo "(* This module was generated automatically by code in Makefile and machdep.c *)" >$@ -# Now generate the type definition - echo "type mach = {" >> $@ - echo " version_major: int; (* Major version number *)" >> $@ - echo " version_minor: int; (* Minor version number *)" >> $@ - echo " version: string; (* version number *)" >> $@ - echo " underscore_name: bool; (* If assembly names have leading underscore *)" >> $@ - echo " sizeof_short: int; (* Size of \"short\" *)" >> $@ - echo " sizeof_int: int; (* Size of \"int\" *)" >> $@ - echo " sizeof_long: int ; (* Size of \"long\" *)" >> $@ - echo " sizeof_longlong: int; (* Size of \"long long\" *)" >> $@ - echo " sizeof_ptr: int; (* Size of pointers *)" >> $@ - echo " sizeof_enum: int; (* Size of enum types *)" >> $@ - echo " sizeof_float: int; (* Size of \"float\" *)" >> $@ - echo " sizeof_double: int; (* Size of \"double\" *)" >> $@ - echo " sizeof_longdouble: int; (* Size of \"long double\" *)" >> $@ - echo " sizeof_sizeof: int; (* Size of \"sizeof(T)\" *)" >> $@ - echo " sizeof_wchar: int; (* Size of \"wchar_t\" *)" >> $@ - echo " sizeof_void: int; (* Size of \"void\" *)" >> $@ - echo " sizeof_fun: int; (* Size of function *)" >> $@ - echo " alignof_short: int; (* Alignment of \"short\" *)" >> $@ - echo " alignof_int: int; (* Alignment of \"int\" *)" >> $@ - echo " alignof_long: int; (* Alignment of \"long\" *)" >> $@ - echo " alignof_longlong: int; (* Alignment of \"long long\" *)" >> $@ - echo " alignof_ptr: int; (* Alignment of pointers *)" >> $@ - echo " alignof_enum: int; (* Alignment of enum types *)" >> $@ - echo " alignof_float: int; (* Alignment of \"float\" *)" >> $@ - echo " alignof_double: int; (* Alignment of \"double\" *)" >> $@ - echo " alignof_longdouble: int; (* Alignment of \"long double\" *)" >> $@ - echo " alignof_str: int; (* Alignment of strings *)" >> $@ - echo " alignof_fun: int; (* Alignment of function *)" >> $@ - echo " char_is_unsigned: bool; (* Whether \"char\" is unsigned *)">> $@ - echo " const_string_literals: bool; (* Whether string literals have const chars *)">> $@ - echo " little_endian: bool; (* whether the machine is little endian *)">>$@ - echo "}" >> $@ - if gcc -D_GNUCC $< -o $(OBJDIR)/machdep.exe ;then \ - echo "machdep.exe created succesfull." \ - ;else \ - rm -f $@; exit 1 \ - ;fi - echo "let gcc = {" >>$@ - $(OBJDIR)/machdep.exe >>$@ - echo " underscore_name = @UNDERSCORE_NAME@ ;" >> $@ - echo "}" >>$@ - if cl /D_MSVC $< /Fe$(OBJDIR)/machdep.exe /Fo$(OBJDIR)/machdep.obj ;then \ - echo "let hasMSVC = true" >>$@ \ - ;else \ - echo "let hasMSVC = false" >>$@ ;fi - echo "let msvc = {" >>$@ - $(OBJDIR)/machdep.exe >>$@ - echo " underscore_name = true ;" >> $@ - echo "}" >>$@ - echo "let gccHas__builtin_va_list = @HAVE_BUILTIN_VA_LIST@" >>$@ - echo "let __thread_is_keyword = @THREAD_IS_KEYWORD@" >>$@ - -# -# Create the version information module -.PHONY: cilversion -cilversion: $(OBJDIR)/cilversion.ml -$(OBJDIR)/cilversion.ml: configure.in Makefile.in - rm -f $@ - echo "(* This module was generated automatically by code in Makefile *)" >$@ -# Generate here the version information - echo "let cilVersionMajor = @CIL_VERSION_MAJOR@" >>$@ - echo "let cilVersionMinor = @CIL_VERSION_MINOR@" >>$@ - echo "let cilVersionRev = @CIL_VERSION_REV@" >>$@ - echo "let cilVersion = \"@CIL_VERSION@\"" >>$@ - -# build two libraries -.PHONY: cillib libcil -ifeq ($(NATIVECAML),1) -cillib: $(OBJDIR)/cil.$(CMXA) # $(OBJDIR)/libcil.a -else -cillib: $(OBJDIR)/cil.$(CMXA) -endif - - -$(OBJDIR)/feature_config.ml: Makefile config.status - rm -f $(OBJDIR)/feature_config.* - echo "(* This module was generated automatically by code in Makefile.in *)" >$@ -# The Cilly feature options. A list of Cil.featureDescr - echo "open Cil" >>$@ - echo "let features : featureDescr list = [" >> $@ -ifdef USE_BLOCKINGGRAPH - echo " Blockinggraph.feature;" >> $@ -endif -ifdef USE_RAND - echo " Rand.feature;" >> $@ -endif -ifdef USE_ARITHABS - echo " Arithabs.feature;" >>$@ -endif -ifdef USE_SMALLOC - echo " Smalloc.feature;" >> $@ -endif -ifdef USE_CQUALANN - echo " Cqualann.feature;" >> $@ -endif -ifdef USE_ZRAPP - echo " Zrapp.feature;" >> $@ -endif -# Now the extra features, with the first letter capitalized - echo \ - $(foreach f,@EXTRAFEATURES@, \ - `echo $f | cut -c 1 | tr "[a-z]" "[A-Z]"``echo $f | cut -c 2-`".feature;") >> $@ - echo "]" >>$@ -# Must delete main.d and remake it, because it may have been made -# before feature_config existed. - rm -f $(DEPENDDIR)/main.d - $(MAKE) $(DEPENDDIR)/main.d - - - - - - -OCAML_CIL_LIB_MODULES := $(CILLY_LIBRARY_MODULES) -OCAML_CIL_LIB_CMODULES := perfcount - -# list of modules to use for building a library; remove 'main' -# and add 'libmaincil' -OCAML_CIL_C_LIB_MODULES := $(CILLY_MODULES:main=) libmaincil - -# Build an OCAML library (CMA / CMXA) that exports our Cil stuff -$(OBJDIR)/cil.$(CMXA): $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) \ - $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO)) - $(CAMLLINK) -a -o $@ -ccopt -L$(pkglibdir) \ - $(OCAML_CIL_LIB_CMODULES:%=-cclib -l%) \ - $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO)) - -$(OBJDIR)/libperfcount.a: %: %($(OBJDIR)/perfcount.$(CMC)) - ranlib $@ - -# sm: for Simon: build a library of CIL functions which can -# be called from C code; this is like the target above, except -# it is callable from C instead of from Ocaml -ifeq ($(NATIVECAML),1) -$(OBJDIR)/libcil.a: $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) \ - $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO)) - ocamlopt -output-obj -o $@ unix.cmxa str.cmxa $^ -else -$(OBJDIR)/libcil.a: - @echo "Can only build $@ when NATIVECAML is 1." - exit 2 -endif - -# Test cil -ifdef _MSVC -TESTCILARG=--MSVC --testcil "bash msvctestcil" -else -TESTCILARG= --testcil "bash gcctestcil" -endif - -.PHONY: testcil -testcil: $(OBJDIR)/cilly$(EXE) - cd test; ../$(OBJDIR)/cilly$(EXE) $(TESTCILARG) - -.PHONY: odoc texdoc pdfdoc - -### -### DOCUMENTATION -### -### The following are available -### -### make doc - creates the documentation -### make publish_doc - creates the documentation and puts it on the web page - -# Documentation generated by "ocamldoc" -odoc: $(OBJDIR)/pretty.cmi $(OBJDIR)/cil.cmi - -rm -rf doc/html/cil/api - -mkdir doc/html/cil/api - -mkdir doc/html/cil/api-latex - -rm -f doc/ocamldoc.sty - ocamldoc -d doc/html/cil/api -v -stars \ - -html \ - -t "CIL API Documentation (version @CIL_VERSION@)" \ - -I $(OBJDIR) \ - ocamlutil/pretty.mli ocamlutil/errormsg.mli \ - ocamlutil/clist.mli \ - ocamlutil/stats.mli src/cil.mli src/formatcil.mli \ - ocamlutil/alpha.mli src/cillower.mli \ - src/ext/cfg.mli src/ext/dataflow.mli \ - src/ext/dominators.mli - -doc/cilpp.tex: doc/cilcode.pl doc/cil.tex - -rm -rf doc/html/cil - -mkdir doc/html/cil - -mkdir doc/html/cil/examples - cd doc; perl cilcode.pl cil.tex >cilpp.tex.tmp - mv doc/cilpp.tex.tmp $@ - -# Documentation generated from latex files using "hevea" -texdoc: doc/cilpp.tex -# Create the version document - cd doc/html/cil; echo "\def\cilversion{@CIL_VERSION@}" >cil.version.tex - cd doc/html/cil; echo "\def\ccuredversion{@CCURED_VERSION@}" >>cil.version.tex - cd doc/html/cil; hevea -exec xxdate.exe ../../cilpp - cd doc/html/cil; hevea -exec xxdate.exe ../../cilpp - cd doc/html/cil; mv cilpp.html cil.html - cd doc/html/cil; hacha -o ciltoc.html cil.html - cp -f doc/index.html doc/html/cil/index.html - cp -f doc/header.html doc/html/cil - -pdfdoc: doc/cilpp.tex $(OBJDIR)/pretty.cmi $(OBJDIR)/cil.cmi - cd doc; echo "\def\cilversion{@CIL_VERSION@}" >cil.version.tex - cd doc; echo "\def\ccuredversion{@CCURED_VERSION@}" >>cil.version.tex - cd doc; pdflatex cilpp.tex; pdflatex cilpp.tex - cd doc; mv cilpp.pdf html/cil/CIL.pdf - ocamldoc -o doc/cil-api.tex -v -stars \ - -latex \ - -t "CIL API Documentation (version @CIL_VERSION@)" \ - -I $(OBJDIR) \ - ocamlutil/pretty.mli ocamlutil/errormsg.mli \ - ocamlutil/clist.mli \ - ocamlutil/stats.mli src/cil.mli src/formatcil.mli \ - ocamlutil/alpha.mli - - cd doc ; TEXINPUTS="$$TEXINPUTS:/usr/local/lib/ocaml/ocamldoc:/usr/lib/ocaml/ocamldoc" pdflatex cil-api.tex - cd doc ; mv cil-api.pdf html/cil/CIL-API.pdf - -doc: texdoc pdfdoc odoc - - -#---------------------------------------------------------------------- -# Generate the CIL distribution -# This will create a file cil.tar.gz. It includes the HTML documentation -# so that people can use it even if they don't have ocamldoc, hevea etc. - -.PHONY: distrib distrib-nocheck checkdistrib -CIL_TAR_GZ:=cil-@CIL_VERSION@.tar.gz -## Make a distribution and check it -distrib: distrib-nocheck checkdistrib - -# Work in a temporary directory -TEMP_DIR = TEMP_cil-distrib - -# The tar archive members will be relative to this directory -TOP_DIR = $(TEMP_DIR)/cil - -DISTRIB_ROOT = README LICENSE INSTALL Makefile.in \ - config.h.in Makefile.gcc Makefile.msvc \ - configure configure.in install-sh config.guess config.sub \ - cil.spec cil.spec.in - -DISTRIB_SRC = cilutil.ml cil.ml cil.mli check.ml check.mli \ - rmtmps.ml rmtmps.mli formatlex.mll formatparse.mly \ - formatcil.mli formatcil.ml testcil.ml \ - mergecil.ml mergecil.mli main.ml machdep.c \ - ciloptions.ml ciloptions.mli libmaincil.ml \ - escape.ml escape.mli cillower.mli cillower.ml - -DISTRIB_OCAMLUTIL = pretty.ml pretty.mli errormsg.ml errormsg.mli \ - trace.ml trace.mli stats.ml stats.mli util.ml util.mli \ - inthash.ml inthash.mli alpha.ml alpha.mli \ - intmap.ml intmap.mli clist.ml clist.mli \ - growArray.ml growArray.mli \ - perfcount.c.in Makefile.ocaml Makefile.ocaml.build - - -DISTRIB_SRC_FRONTC = cabs.ml cprint.ml clexer.mli clexer.mll \ - cparser.mly lexerhack.ml \ - cabs2cil.ml cabs2cil.mli frontc.ml frontc.mli \ - cabsvisit.mli cabsvisit.ml patch.mli patch.ml - -DISTRIB_SRC_EXT = logcalls.ml logcalls.mli \ - astslicer.ml heap.ml partial.ml \ - logwrites.ml heapify.ml callgraph.ml callgraph.mli \ - epicenter.ml usedef.ml ciltools.ml \ - cfg.ml deadcodeelim.ml availexps.ml \ - dataflow.ml dataflow.mli \ - dominators.ml dominators.mli \ - bitmap.ml bitmap.mli \ - ssa.ml ssa.mli \ - stackoverflow.mli stackoverflow.ml \ - canonicalize.ml canonicalize.mli \ - oneret.ml oneret.mli sfi.ml \ - simplemem.ml simplify.ml \ - blockinggraph.ml blockinggraph.mli \ - dataslicing.ml dataslicing.mli \ - reachingdefs.ml \ - cfg.ml cfg.mli \ - liveness.ml - -DISTRIB_SRC_EXT_PTA = setp.ml setp.mli golf.ml golf.mli \ - ptranal.ml ptranal.mli \ - steensgaard.mli steensgaard.ml \ - uref.ml uref.mli olf.ml olf.mli - -DISTRIB_LIB = Cilly.pm KeptFile.pm OutputFile.pm TempFile.pm - -DISTRIB_BIN = CilConfig.pm.in cilly cilly.bat.in \ - patcher patcher.bat.in test-bad teetwo - -DISTRIB_SMALL1=hello.c func.c init.c init1.c wchar1.c vararg1.c testharness.h - -distrib-nocheck: $(DISTRIB_ROOT) doc - # Create the distribution from scratch - rm -rf $(TEMP_DIR) - mkdir $(TEMP_DIR) - - rm -rf $(CIL_TAR_GZ) - mkdir $(TOP_DIR) \ - $(TOP_DIR)/src \ - $(TOP_DIR)/src/frontc \ - $(TOP_DIR)/src/ext \ - $(TOP_DIR)/src/ext/pta \ - $(TOP_DIR)/obj \ - $(TOP_DIR)/doc \ - $(TOP_DIR)/lib \ - $(TOP_DIR)/bin \ - $(TOP_DIR)/doc/api \ - $(TOP_DIR)/obj/.depend \ - $(TOP_DIR)/obj/x86_WIN32 \ - $(TOP_DIR)/obj/x86_LINUX \ - $(TOP_DIR)/obj/ppc_DARWIN \ - $(TOP_DIR)/obj/sparc_SOLARIS \ - $(TOP_DIR)/test \ - $(TOP_DIR)/test/small1 \ - $(TOP_DIR)/ocamlutil - - cp $(patsubst %,%,$(DISTRIB_ROOT)) $(TOP_DIR) - - cp $(patsubst %,src/%,$(DISTRIB_SRC)) $(TOP_DIR)/src - cp $(patsubst %,ocamlutil/%,$(DISTRIB_OCAMLUTIL)) $(TOP_DIR)/ocamlutil - cp $(patsubst %,src/ext/%,$(DISTRIB_SRC_EXT)) $(TOP_DIR)/src/ext - cp $(patsubst %,src/ext/pta/%,$(DISTRIB_SRC_EXT_PTA)) \ - $(TOP_DIR)/src/ext/pta - cp $(patsubst %,src/frontc/%,$(DISTRIB_SRC_FRONTC)) \ - $(TOP_DIR)/src/frontc - cp $(patsubst %,lib/%,$(DISTRIB_LIB)) $(TOP_DIR)/lib - cp $(patsubst %,bin/%,$(DISTRIB_BIN)) $(TOP_DIR)/bin - cp $(patsubst %,test/small1/%,$(DISTRIB_SMALL1)) $(TOP_DIR)/test/small1 - - cp -r doc/html/cil/* $(TOP_DIR)/doc -# Delete all CVS directories - if find $(TEMP_DIR) -name CVS -print >cvss.txt ; then \ - rm -rf `cat cvss.txt` ;fi -# Now make the TAR ball - cd $(TEMP_DIR); tar cfz $(CIL_TAR_GZ) cil - mv $(TEMP_DIR)/$(CIL_TAR_GZ) . - -# rm -rf $(TEMP_DIR) - -## Check a distribution -checkdistrib: - cd $(TOP_DIR) && ./configure && \ - $(MAKE) && $(MAKE) quicktest - -distclean: clean - rm -f src/frontc/cparser.output - rm -f src/formatparse.output - rm -f ocamlutil/perfcount.c - rm -f bin/cilly.bat - rm -f bin/patcher.bat - rm -f bin/CilConfig.pm - rm -f config.log - rm -f config.h - rm -f Makefile - -## Publish the distribution -CILHTMLDEST=/var/www/cil -publish_distrib: publish_doc - if test -d $(CILHTMLDEST); then \ - cp -rf doc/html/cil/* $(CILHTMLDEST); \ - cp -f $(CIL_TAR_GZ) $(CILHTMLDEST)/distrib; \ - ln -sf $(CILHTMLDEST)/distrib/$(CIL_TAR_GZ) $(CILHTMLDEST)/distrib/cil-latest.tar.gz ; \ - echo "Publish succeeded"; \ - else \ - error "Cannot publish because $(CILHTMLDEST) does not exist" ; \ - fi - -publish_doc: doc - if test -d $(CILHTMLDEST); then \ - cp -rf doc/html/cil/* $(CILHTMLDEST); echo "Done publishing doc"; \ - else \ - error "Cannot publish because $(CILHTMLDEST) does not exist" ; \ - fi - -cleancheck: - rm -f test/small1/*.o - rm -f test/small1/hello - rm -f test/small1/vararg1 - rm -f test/small1/wchar1 - -clean: cleancaml cleancheck - rm -f $(OBJDIR)/machdep.ml - -# Now include the compiler specific stuff -ifdef _MSVC - include Makefile.msvc -else - ifdef _GNUCC - include Makefile.gcc - endif -endif - -test/%: - bin/cilly $(CONLY) test/small1/$*.c $(OBJOUT)test/small1/$*.o - -testrun/%: - bin/cilly test/small1/$*.c $(OBJOUT)test/small1/$* - test/small1/$* - - - -.PHONY: quicktest -quicktest: $(patsubst %,test/%,func init init1) \ - $(patsubst %,testrun/%,hello wchar1 vararg1) - -.PHONY: check -check: quicktest - -############# Binary distribution ################ -.PHONY: bindistrb checkbindistrib - -BINCIL_TAR_GZ:=cil-win32-@CIL_VERSION@.tar.gz - -# Work in a temporary directory -BINTEMP_DIR = TEMP_cil-bindistrib - -# The tar archive members will be relative to this directory -BINTOP_DIR = $(BINTEMP_DIR)/cil - -BINDISTRIB_ROOT = README LICENSE - -BINDISTRIB_LIB = Cilly.pm KeptFile.pm OutputFile.pm TempFile.pm - -BINDISTRIB_BIN = CilConfig.pm.in cilly cilly.bat.in \ - patcher patcher.bat.in - -BINDISTRIB_OBJ = cilly.byte.exe cilly.asm.exe - -BINDISTRIB_SMALL1=hello.c - -bindistrib-nocheck: $(BINDISTRIB_ROOT) obj/x86_WIN32/cilly.asm.exe - # Create the distribution from scratch - rm -rf $(BINTEMP_DIR) - mkdir $(BINTEMP_DIR) - - mkdir $(BINTOP_DIR) \ - $(BINTOP_DIR)/obj \ - $(BINTOP_DIR)/doc \ - $(BINTOP_DIR)/lib \ - $(BINTOP_DIR)/bin \ - $(BINTOP_DIR)/doc/api \ - $(BINTOP_DIR)/obj/.depend \ - $(BINTOP_DIR)/obj/x86_WIN32 \ - $(BINTOP_DIR)/test \ - $(BINTOP_DIR)/test/small1 - - cp $(patsubst %,%,$(BINDISTRIB_ROOT)) $(BINTOP_DIR) - cp $(patsubst %,lib/%,$(BINDISTRIB_LIB)) $(BINTOP_DIR)/lib - cat bin/CilConfig.pm.in \ - | sed -e "s|@||g" \ - | sed -e "s|CC|cl|" \ - | sed -e "s|DEFAULT_CIL_MODE|MSVC|" \ - | sed -e "s|ARCHOS|x86_WIN32|" \ - > $(BINTOP_DIR)/bin/CilConfig.pm - cat bin/patcher.bat.in | sed -e "s|@||g" >$(BINTOP_DIR)/bin/patcher.bat - cp bin/patcher $(BINTOP_DIR)/bin - cp bin/cilly $(BINTOP_DIR)/bin - cat bin/cilly.bat.in | sed -e "s|@||g" > $(BINTOP_DIR)/bin/cilly.bat - cp $(patsubst %,test/small1/%,$(BINDISTRIB_SMALL1)) \ - $(BINTOP_DIR)/test/small1 - cp $(patsubst %,obj/x86_WIN32/%,$(BINDISTRIB_OBJ)) \ - $(BINTOP_DIR)/obj/x86_WIN32 - - cp -r doc/html/cil/* $(BINTOP_DIR)/doc -# Delete all CVS directories - if find $(BINTEMP_DIR) -name CVS -print >cvss.txt ; then \ - rm -rf `cat cvss.txt` ;fi -# Now make the TAR ball - cd $(BINTEMP_DIR); tar cfz $(BINCIL_TAR_GZ) cil - mv $(BINTEMP_DIR)/$(BINCIL_TAR_GZ) . - -# rm -rf $(TEMP_DIR) - -## Check a distribution -checkbindistrib: - -######################################################################## - - -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -libdir = @libdir@ -pkglibdir = $(libdir)/cil -datadir = @datadir@ -pkgdatadir = $(datadir)/cil - -all_mli := $(filter %.mli, $(DISTRIB_OCAMLUTIL) $(DISTRIB_SRC) $(DISTRIB_SRC_FRONTC) $(DISTRIB_SRC_EXT) $(DISTRIB_SRC_EXT_PTA)) -install_mli := $(filter $(OCAML_CIL_LIB_MODULES:=.mli), $(all_mli)) -install_cmi := $(install_mli:%.mli=$(OBJDIR)/%.cmi) -install_cma := $(addprefix $(OBJDIR)/cil., cma cmxa a) -install_lib := $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) - -install: $(install_cmi) $(install_cma) $(install_lib) - $(INSTALL) -d $(DESTDIR)$(pkglibdir) - $(INSTALL_DATA) $(install_cma) $(DESTDIR)$(pkglibdir) - $(INSTALL_DATA) $(install_cmi) $(DESTDIR)$(pkglibdir) - $(INSTALL_DATA) $(install_lib) $(DESTDIR)$(pkglibdir) - $(INSTALL) -d $(DESTDIR)$(pkgdatadir) - $(INSTALL_DATA) $(addprefix lib/, $(filter %.pm, $(DISTRIB_LIB))) $(DESTDIR)$(pkgdatadir) - -cil.spec: cil.spec.in - ./config.status $@ - -rpms: distrib - rpmbuild -ta $(CIL_TAR_GZ) - diff --git a/cil/Makefile.msvc b/cil/Makefile.msvc deleted file mode 100644 index be1bb38..0000000 --- a/cil/Makefile.msvc +++ /dev/null @@ -1,42 +0,0 @@ -# -# Makefile for CCured. The Microsoft Visual C part -# -COMPILERNAME=MSVC - -CC:=cl /nologo -ifdef RELEASELIB -#matth: we need the frame pointer for CHECK_GETFRAME, so -# use /Oy- to prevent that optimization. - CFLAGS:=/DRELEASE /D_MSVC /Ox /Ob2 /G6 /Oy- -else - CFLAGS:=/D_DEBUG /D_MSVC /Zi /MLd -endif -CONLY:=/c - -OPT_O2:= /Ox /Ob2 /G6 - -OBJOUT:=/Fo -OBJEXT:=obj - -EXEOUT:=/Fe -LIBEXT:=lib -LDEXT:=.exe - -DEF:=/D -ASMONLY:=/Fa -INC:=/I - -CPPSTART:=cl /Dx86_WIN32 /D_MSVC /E /TC /I./lib /DCCURED -CPPOUT:= >%o -CPP:=$(CPPSTART) /FI fixup.h %i $(CPPOUT) - -PATCHECHO:=echo - -AR:=lib -LIBOUT:=/OUT: - -# The system include files to be patched -PATCH_SYSINCLUDES:=stdio.h ctype.h string.h io.h stdarg.h crtdbg.h \ - varargs.h stdlib.h time.h malloc.h - - diff --git a/cil/README b/cil/README deleted file mode 100644 index 52710f2..0000000 --- a/cil/README +++ /dev/null @@ -1,2 +0,0 @@ - - See the documentation in doc/html. diff --git a/cil/bin/CilConfig.pm.in b/cil/bin/CilConfig.pm.in deleted file mode 100644 index 94241b1..0000000 --- a/cil/bin/CilConfig.pm.in +++ /dev/null @@ -1,6 +0,0 @@ - -$::archos = "@ARCHOS@"; -$::cc = "@CC@"; -$::cilhome = "@CILHOME@"; -$::default_mode = "@DEFAULT_CIL_MODE@"; - diff --git a/cil/bin/cilly b/cil/bin/cilly deleted file mode 100755 index e4bf737..0000000 --- a/cil/bin/cilly +++ /dev/null @@ -1,152 +0,0 @@ -#!/usr/bin/perl -# A simple use of the Cilly module -# -# -# -# Copyright (c) 2001-2002, -# George C. Necula -# Scott McPeak -# Wes Weimer -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# 3. The names of the contributors may not be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -# -use strict; -use Data::Dumper; -use FindBin; -use lib "$FindBin::Bin"; -use lib "$FindBin::Bin/../lib"; # The libraries are in the lib directory -# Read the configuration script -use CilConfig; - -use Cilly; - -$::default_is_merge = 0; -my $stub = CilCompiler->new(@ARGV); - -$stub->setVersion (); - -# print Dumper($stub); -$stub->doit(); - - -# Define here your favorite compiler by overriding Merger methods -package CilCompiler; -use File::Basename; -use strict; -BEGIN { - @CilCompiler::ISA = qw(Cilly); - $CilCompiler::base = "$::cilhome/obj/$::archos/cilly"; - # Use the most recent version of cilly - $CilCompiler::mtime_asm = int((stat("$CilCompiler::base.asm.exe"))[9]); - $CilCompiler::mtime_byte = int((stat("$CilCompiler::base.byte.exe"))[9]); - $CilCompiler::use_debug = - grep(/--bytecode/, @ARGV) || - grep(/--ocamldebug/, @ARGV) || - ($CilCompiler::mtime_asm < $CilCompiler::mtime_byte); - $CilCompiler::compiler = - $CilCompiler::base . - ($CilCompiler::use_debug ? ".byte" : ".asm") . ".exe"; - if($CilCompiler::use_debug) { - $ENV{"OCAMLRUNPARAM"} = "b" . $ENV{"OCAMLRUNPARAM"}; - } -} - -# We need to customize the collection of arguments -sub collectOneArgument { - my($self, $arg, $pargs) = @_; - if($arg =~ m|--transval=(.+)$|) { - $self->{TRANSVAL} = $1; return 1; - } - if($arg eq '--ocamldebug') { - $self->{OCAMLDEBUG} = 1; return 1; - } - if($arg eq '--cabsonly') { - $self->{CABSONLY} = 1; return 1; - } - # See if the super class understands this - return $self->SUPER::collectOneArgument($arg, $pargs); -} - -sub usage { - print "Usage: cilly [options] [gcc_or_mscl arguments]\n"; -} - -sub helpMessage { - my($self) = @_; - # Print first the original - $self->SUPER::helpMessage(); - print <runShell(@cmd); -} - - -sub CillyCommand { - my ($self, $ppsrc, $dest) = @_; - - my $aftercil; - my @cmd = ($CilCompiler::compiler); - - if(defined $ENV{OCAMLDEBUG} || $self->{OCAMLDEBUG}) { - print "OCAMLDEBUG is on\n"; - my @idirs = ("src", "src/frontc", "src/ccured", "src/ext", - "ocamlutil", - "obj/$::archos"); - my @iflags = map { ('-I', "$::cilhome/$_") } @idirs; - unshift @cmd, 'ocamldebug', '-emacs', @iflags; - } - if($::docxx) { - push @cmd, '--cxx'; - } - if($self->{CABSONLY}) { - $aftercil = $self->cilOutputFile($dest, 'cabs.c'); - push @cmd, '--cabsonly', $aftercil; - } else { - if(defined $self->{CILLY_OUT}) { - $aftercil = new OutputFile($dest, $self->{CILLY_OUT}); - return ($aftercil, @cmd); - } - $aftercil = $self->cilOutputFile($dest, 'cil.c'); - } - return ($aftercil, @cmd, '--out', $aftercil); -} - -sub MergeCommand { - my ($self, $ppsrc, $dir, $base) = @_; - - return ('', $CilCompiler::compiler); -} - - -1; diff --git a/cil/bin/cilly.bat.in b/cil/bin/cilly.bat.in deleted file mode 100755 index 9e5a36e..0000000 --- a/cil/bin/cilly.bat.in +++ /dev/null @@ -1 +0,0 @@ -perl @CILHOME@/bin/cilly %* diff --git a/cil/bin/patcher b/cil/bin/patcher deleted file mode 100755 index 6eb7d15..0000000 --- a/cil/bin/patcher +++ /dev/null @@ -1,605 +0,0 @@ -#!/usr/bin/perl -# A Perl script that patches a bunch of files -# -# -# -# Copyright (c) 2001-2002, -# George C. Necula -# Scott McPeak -# Wes Weimer -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# 3. The names of the contributors may not be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -# -use strict; -use File::Basename; -use File::Copy; -use Getopt::Long; # Command-line option processing -use Data::Dumper; -use FindBin; -use lib "$FindBin::Bin"; -use lib "$FindBin::Bin/../lib"; -# Read the configuration script -use CilConfig; - -$::iswin32 = $^O eq 'MSWin32' || $^O eq 'cygwin'; -# matth: On cygwin, ^O is either MSWin32 or cygwin, depending on how you build -# perl. We don't care about the distinction, so just treat all windows -# platforms the same when looking at "system=cygwin" tags on patches. -$::platform = $::iswin32 ? 'cygwin' : $^O; - - -# Set filename parsing according to current operating system. -File::Basename::fileparse_set_fstype($^O); - -sub printHelp { - print <) - - --clean Remove all files in the destination directory - --dumpversion Print the version name used for the current compiler - - All of the other arguments are passed to the preprocessor. - -We will use \"$::platform\" as your system type. - -Send bugs to necula\@cs.berkeley.edu. -EOL -} - - -my %option; -&Getopt::Long::Configure("pass_through"); -&Getopt::Long::GetOptions - (\%option, - "--help", # Display help information - "--verbose|v", # Display information about programs invoked - "--mode=s", # The mode (GNUCC, MSVC) - "--dest=s", # The destination directory - "--patch=s@", # Patch files - "--ufile=s@", # User include files - "--sfile=s@", # System include files - "--dumpversion", - "--clean", - ); - -if($option{help}) { - &printHelp(); - exit 0; -} - -# print Dumper({"option" => \%option, "ARGV" => \@ARGV}); - -my $cversion; # Compiler version -my $cname; # Compiler name -my @patches; # A list of the patches to apply - -my $ppargs = join(' ', @ARGV); - -my %groups; - -&findCompilerVersion(); - -if($option{dumpversion}) { - print $cversion; - exit 0; -} - -# Find the destination directory -if(!defined($option{dest})) { - die "Must give a --dest directory\n"; -} -if(! -d $option{dest}) { - die "The destination directory $option{dest} does not exist\n"; -} - -if($option{clean}) { - # Find the destination directory for a dummy file - my $dest = &destinationFileName(""); - chop $dest; # The final / - print "Cleaning all files in $dest\n"; - (!system("rm -rf $dest")) || die "Cannot remove directory\n"; - exit 0; -} - -print "Patching files for $cname version $cversion\n"; - -# Prepare the patches -if(defined($option{patch})) { - my $pFile; - foreach $pFile (@{$option{patch}}) { - &preparePatchFile($pFile); - } -} - -# print Dumper(\@patches); - -my $file; -foreach $file (@{$option{ufile}}) { - &patchOneFile($file, 0); -} -foreach $file (@{$option{sfile}}) { - &patchOneFile($file, 1); -} - -# Now check whether we have used all the patches -my $hadError = 0; -foreach my $patch (@patches) { - # It was optional - if(defined $patch->{FLAGS}->{optional} || - defined $patch->{FLAGS}->{disabled}) { next; } - # It was for another system - if(defined $patch->{FLAGS}->{system} && - $patch->{FLAGS}->{system} ne $::platform) { next; } - # Its group was done - if(defined $patch->{FLAGS}->{group}) { - if(! defined $groups{$patch->{FLAGS}->{group}}) { - $hadError = 1; - print "None of the following patches from group $patch->{FLAGS}->{group} was used:\n"; - foreach my $gp (@patches) { - if($gp->{FLAGS}->{group} eq $patch->{FLAGS}->{group}) { - print "\tfrom $gp->{PATCHFILE} at $gp->{PATCHLINENO}\n"; - } - } - $groups{$patch->{FLAGS}->{group}} = 1; # We're done with it - } - next; - } - # It was not in a group and was not optional - if(! defined $patch->{USED}) { - $hadError = 1; - print "Non-optional patch was not used:\n\tfrom $patch->{PATCHFILE} at $patch->{PATCHLINENO}\n"; - next; - } -} -exit $hadError; - - -############# SUBROUTINES -sub findCompilerVersion { - $cname = ""; - $cversion = 0; - if($option{mode} eq "GNUCC") { - $cname = "GNU CC"; - open(VER, "$::cc -dumpversion $ppargs|") - || die "Cannot start $cname"; - while() { - # sm: had to modify this to match "egcs-2.91.66", which is - # how egcs responds to the -dumpversion request - if($_ =~ m|^(\d+\S+)| || - $_ =~ m|^(egcs-\d+\S+)|) { - $cversion = "gcc_$1"; - close(VER) || die "Cannot start $cname\n"; - return; - } - } - die "Cannot find the version for GCC\n"; - } - if($option{mode} eq "MSVC") { - $cname = "Microsoft cl"; - $ppargs =~ s|/nologo||g; - open(VER, "cl $ppargs 2>&1|") || die "Cannot start $cname: cl $ppargs\n"; - while() { - if($_ =~ m|Compiler Version (\S+) |) { - $cversion = "cl_$1"; - close(VER); - return; - } - } - die "Cannot find the version for Microsoft CL\n"; - } - die "You must specify a --mode (either GNUCC or MSVC)"; -} - -sub lineDirective { - my ($fileName, $lineno) = @_; - if($::iswin32) { - $fileName =~ s|\\|/|g; - } - if($option{mode} eq "MSVC") { - return "#line $lineno \"$fileName\"\n"; - } - if($option{mode} eq "GNUCC" || $option{mode} eq "EDG") { - return "# $lineno \"$fileName\"\n"; - } - die "lineDirective: invalid mode"; -} - -# Find the absolute name for a file -sub patchOneFile { - my ($fname, $issys) = @_; - my $fname1 = $issys ? "<$fname>" : "\"$fname\""; - print "Patching $fname1\n"; - my $preprocfile = "__topreproc"; - unlink "$preprocfile.i"; - open(TOPREPROC, ">$preprocfile.c") || die "Cannot open preprocessor file"; - print TOPREPROC "#include $fname1\n"; - close(TOPREPROC); - # Do not test for error while running the preprocessor because the - # error might be due to an #error directive - my $preproccmd = ""; - if($option{mode} eq "GNUCC") { - $preproccmd = "$::cc -E $ppargs $preprocfile.c >$preprocfile.i"; - if ($^O ne 'MSWin32') { # Windows has no /dev/null - # ignore stderr (e.g. #error directives) - $preproccmd .= " 2>/dev/null"; - } - } elsif($option{mode} eq "MSVC") { - $preproccmd = "cl /nologo /P $ppargs $preprocfile.c"; - } else { die "Invalid --mode"; } - - if(system($preproccmd) && $option{mode} eq "MSVC" ) { - # For some reason the gcc returns spurious error codes - die "Error running preprocessor: $preproccmd" - } - - # Now scan the resulting file and get the real name of the file - my $absname = ""; - open(PPOUT, "<$preprocfile.i") || die "Cannot find $preprocfile.i"; - while() { - if($_ =~ m|^\#.+\"(.+$fname)\"|) { - $absname = $1; - last; - } - } - close(PPOUT); - if($absname eq "") { - die "Cannot find the absolute name of $fname1 in $preprocfile.i\n"; - } - unlink "$preprocfile.c"; - unlink "$preprocfile.i"; - # If we fail then maybe we are using cygwin paths in a Win32 system - if($option{mode} eq "GNUCC" && $::iswin32) { - open(WINNAME, "cygpath -w $absname|") - || die "Cannot run cygpath to convert $absname to a Windows name"; - $absname = ; - if($absname =~ m|\n$|) { - chop $absname; - } - # print "Converted $fileName to $newName\n"; - close(WINNAME) || die "Cannot run cygpath to convert $absname"; - } - if(! -f $absname) { #matth: we need to do this test after calling cygpath - die "Cannot find the absolute name of $fname1 (\"$absname\")\n"; - } - print " Absolute name is $absname\n"; - # Decide where to put the result - my $dest = &destinationFileName($fname); - print " Destination is $dest\n"; - &applyPatches($absname, $dest); -} - -# Is absolute path name? -sub isAbsolute { - my($name) = @_; - if($::iswin32) { - return ($name =~ m%^([a-zA-Z]:)?[/\\]%); - } else { - return ($name =~ m%^[/\\]%); - } -} - -# Compute the destination file name and create all necessary directories -sub destinationFileName { - my ($fname) = @_; - if(&isAbsolute($fname)) { - die "Cannot process files that have absolute names\n"; - } - my $dest = $option{dest} . "/" . $cversion; - # Break the file name into components - my @fnamecomp = split(m%[/\\]%, $fname); - # Add one component at a time - do { - if(! -d $dest) { - (mkdir $dest, 0777) || die "Cannot create directory $dest\n"; - } - my $comp = shift @fnamecomp; - $dest .= ('/' . $comp); - } while($#fnamecomp >= 0); - return $dest; -} -##################################################################### -# Patching of files -# -sub preparePatchFile { - my ($pFile) = @_; - open(PFILE, "<$pFile") || - die "Cannot read patch file $pFile\n"; - my $patchLineNo = 0; - my $patchStartLine = 0; - NextPattern: - while() { - $patchLineNo ++; - if($_ !~ m|^<<<(.*)$|) { - next; - } - # Process the flags - my @patchflags = split(/\s*,\s*/, $1); - my %valueflags; - foreach my $flg (@patchflags) { - $flg = &trimSpaces($flg); - if($flg =~ m|^(.+)\s*=\s*(.+)$|) { - $valueflags{$1} = $2; - } else { - $valueflags{$flg} = 1; - } - } - # Now we have found the start - $_ = ; - $patchLineNo ++; - my $current_pattern = []; - my @all_patterns = (); - if($_ =~ m|^===|) { - if(! defined $valueflags{ateof} && - ! defined $valueflags{atsof}) { - die "A pattern is missing in $pFile"; - } - goto AfterPattern; - } - if($_ eq "") { - die "A pattern is missing in $pFile"; - } - push @{$current_pattern}, $_; - - while() { - $patchLineNo ++; - if($_ =~ m|^===|) { - last; - } - if($_ =~ m%^\|\|\|%) { - # This is an alternate pattern - push @all_patterns, $current_pattern; - $current_pattern = []; - next; - } - push @{$current_pattern}, $_; - } - AfterPattern: - # Finish off the last pattern - push @all_patterns, $current_pattern; - if($_ !~ m|^===|) { - die "No separator found after pattern in $pFile"; - } - $patchStartLine = $patchLineNo + 1; - my $replacement = ""; - # If we have more than one non-optional pattern with no group - # specified, then create a group - if(@all_patterns > 1 && - ! defined $valueflags{group} && - ! defined $valueflags{optional}) { - $valueflags{group} = $pFile . "_$patchStartLine"; - } - while() { - $patchLineNo ++; - if($_ =~ m|^>>>|) { - # For each alternate pattern - my $patt; - foreach $patt (@all_patterns) { - # Maybe the @__pattern__@ string appears in the replacement - my $pattern_repl = join('', @{$patt}); - my $nrlines = int(@{$patt}); - my $local_repl = $replacement; - $local_repl =~ s/\@__pattern__\@/$pattern_repl/g; - # Strip the spaces from patterns - my @pattern_no_space = (); - my $i; - foreach $i (@{$patt}) { - $i =~ s/\s+//g; - push @pattern_no_space, $i; - } - push @patches, { HEAD => $pattern_no_space[0], - FLAGS => \%valueflags, - NRLINES => $nrlines, - PATTERNS => \@pattern_no_space, - REPLACE => $local_repl, - PATCHFILE => $pFile, - PATCHLINENO => $patchStartLine, - }; - } - next NextPattern; - } - $replacement .= $_; - } - die "Unfinished replacement for pattern in $pFile"; - } - close(PFILE) || - die "Cannot close patch file $pFile\n"; - print "Loaded patches from $pFile\n"; - # print Dumper(\@patches); die "Here\n"; - -} - -sub trimSpaces { - my($str) = @_; - if($str =~ m|^\s+(\S.*)$|) { - $str = $1; - } - if($str =~ m|^(.*\S)\s+$|) { - $str = $1; - } - return $str; -} - - -my @includeReadAhead = (); -sub readIncludeLine { - my($infile) = @_; - if($#includeReadAhead < 0) { - my $newLine = <$infile>; - return $newLine; - } else { - return shift @includeReadAhead; - } -} - -sub undoReadIncludeLine { - my($line) = @_; - push @includeReadAhead, $line; -} - -sub applyPatches { - my($in, $out) = @_; - # Initialize all the patches - my $patch; - # And remember the EOF patches that are applicable here - my @eof_patches = (); - foreach $patch (@patches) { - $patch->{USE} = 1; - my $infile = $patch->{FLAGS}->{file}; - if(defined $infile && $in !~ m|$infile$|) { -# print "Will not use patch ", -# &lineDirective($patch->{PATCHFILE},$patch->{PATCHLINENO}); - $patch->{USE} = 0; - next; - } - # Disable the system specific patterns - if(defined $patch->{FLAGS}->{system} && - $patch->{FLAGS}->{system} ne $::platform) { - $patch->{USE} = 0; - next; - } - # Disable also (for now) the patches that must be applied at EOF - if(defined $patch->{FLAGS}->{ateof} || - defined $patch->{FLAGS}->{atsof} || - defined $patch->{FLAGS}->{disabled} ) { - $patch->{USE} = 0; - push @eof_patches, $patch; - } - - } - - open(OUT, ">$out") || die "Cannot open patch output file $out"; - open(IN, "<$in") || die "Cannot open patch input file $in"; - - @includeReadAhead = (); - - my $lineno = 0; - my $line; # The current line - - # the file name that should be printed in the line directives - my $lineDirectiveFile = $in; - # Now apply the SOF patches - foreach my $patch (@eof_patches) { - if(defined $patch->{FLAGS}->{atsof}) { - my $line = &applyOnePatch($patch, &lineDirective($in, $lineno)); - print OUT $line; - } - } - - while($line = &readIncludeLine(\*IN)) { - $lineno ++; - # Now we have a line to print out. See if it needs patching - my $patch; - my @lines = ($line); # A number of lines - my $nrLines = 1; # How many lines - my $toundo = 0; - NextPatch: - foreach $patch (@patches) { - if(! $patch->{USE}) { next; } # We are not using this patch - my $line_no_spaces = $line; - $line_no_spaces =~ s/\s+//g; - if($line_no_spaces eq $patch->{HEAD}) { - # Now see if all the lines match - my $patNrLines = $patch->{NRLINES}; - if($patNrLines > 1) { - # Make sure we have enough lines - while($nrLines < $patNrLines) { - push @lines, &readIncludeLine(\*IN); - $nrLines ++; - $toundo ++; - } - my @checkLines = @{$patch->{PATTERNS}}; - my $i; - # print "check: ", join(":", @checkLines); - # print "with $nrLines lines: ", join("+", @lines); - for($i=0;$i<$patNrLines;$i++) { - $line_no_spaces = $lines[$i]; - $line_no_spaces =~ s/\s+//g; - if($checkLines[$i] ne $line_no_spaces) { - # print "No match for $patch->{HEAD}\n"; - next NextPatch; - } - } - } - # print "Using patch from $patch->{PATCHFILE}:$patch->{PATCHLINENO} at $in:$lineno\n"; - # Now replace - $lineno += ($patNrLines - 1); - $toundo -= ($patNrLines - 1); - $line = &applyOnePatch($patch, &lineDirective($in, $lineno + 1)); - last; - } - } - print OUT $line; - # Now undo all but the first line - my $i; - for($i=$nrLines - $toundo;$i<$nrLines;$i++) { - &undoReadIncludeLine($lines[$i]); - } - } - close(IN) || die "Cannot close file $in"; - # Now apply the EOF patches - foreach $patch (@eof_patches) { - if(defined $patch->{FLAGS}->{ateof}) { - my $line = &applyOnePatch($patch, &lineDirective($in, $lineno)); - print OUT $line; - } - } - - close(OUT); - return 1; -} - - -sub applyOnePatch { - my($patch, $after) = @_; - my $line = &lineDirective($patch->{PATCHFILE}, - $patch->{PATCHLINENO}); - $line .= $patch->{REPLACE}; - $line .= $after; - # Mark that we have used this group - $patch->{USED} = 1; - if(defined $patch->{FLAGS}->{group}) { - $groups{$patch->{FLAGS}->{group}} = 1; - } - return $line; -} diff --git a/cil/bin/patcher.bat.in b/cil/bin/patcher.bat.in deleted file mode 100755 index 2e356ae..0000000 --- a/cil/bin/patcher.bat.in +++ /dev/null @@ -1 +0,0 @@ -perl @CILHOME@/bin/patcher %* diff --git a/cil/bin/teetwo b/cil/bin/teetwo deleted file mode 100755 index 2aa68fa..0000000 --- a/cil/bin/teetwo +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/bash -# run a command, sending stdout to one file and stderr to another, -# but also sending both to this process' stdout/stderr, respectively - -if [ "$3" = "" ]; then - echo "usage: $0 stdout-file stderr-file cmd [args..]" - exit 0 -fi - -stdoutFile="$1" -stderrFile="$2" -command="$3" -shift -shift -shift - -result=0 -handler() { - # this signal means the underlying command exit erroneously, - # though we don't know the code - echo "The command failed!" - result=2 -} -trap handler SIGUSR1 - -# dup my stdout/err on fd 3,4 -exec 3>&1 -exec 4>&2 - - -# run the command with tees to duplicate the data -mypid=$$ -# echo "mypid = $mypid, command=$command, args=$@, stdout=$stdoutFile, stderr=$stderrFile" -(("$command" "$@" || kill -s USR1 $mypid) | tee "$stdoutFile" >&3) 2>&1 | tee "$stderrFile" >&4 - -exit $result diff --git a/cil/bin/test-bad b/cil/bin/test-bad deleted file mode 100755 index 4eacdc0..0000000 --- a/cil/bin/test-bad +++ /dev/null @@ -1,202 +0,0 @@ -#!/bin/sh -# run a regression test containing one or more intentional failures -# -# To create a source file to be processed by this script do the following: -# - the file should be a standalone program with main without any arguments -# You can add other files as part of the CFLAGS variable -# - add a comment -# // NUMERRORS n -# where n is the number of errors to be tested by this file -# -# This file is processed n+1 times. The first time, it should succeed (main returns or -# exits with code 0) and the other n times it should fail. -# For each run the preprocessor variable ERROR is defined to be -# be k (0 <= k <= n). -# You can mark certain lines in your program so that they are used ONLY in a certain run: put the -# following comment after a line to make it appear only in the run with ERROR == 3 -# -# some_code; // ERROR(3) -# -# -# Furthermore, for each run that is intended to fail you can specify a string that -# must appear in the output. -# -# some_code; // ERROR(3):this string must appear in output -# -# Do not put any spaces around the : -# -# Simple example: -# -# #define E(n) {printf("Error %d\n", n); exit(n); } -# #define SUCCESS {printf("Success\n"); exit(0); } -# -# // NUMERRORS 3 -# int main() { -# -# char char x; // ERROR(1):invalid type specifier -# int y; -# int z = ++y; -# // This conditional should be true -# if(z == y) E(2); // ERROR(2):Error 2 -# -# #if ERROR == 3 -# z = (++y, y--); -# if(z == y + 1) E(3); // ERROR(3):Error 3 -# #endif -# -# SUCCESS; -# } -# -# -# set RUNONLY=n to run only the test case n -# - -if [ "$1" = "" ]; then - # most parameters are passed by name, instead of as positional - # arguments, for better impedance match with Makefile; but it's - # good to have at least 1 positional arg so when it's missing I - # can easily tell, and print this message - echo "usage: CILHOME=... CILLY=... CFLAGS=... $0 source-file.c" - echo "You can also set RUNONLY=n to run only the nth iteration" - exit 0 -fi -echo "CILLY=$CILLY" -echo "CFLAGS=$CFLAGS" -srcfile="$1" -# Construct the name of the temporary file to use -srcfilenoext=`echo $srcfile | sed s/.c\$//` -tmpname="$srcfilenoext-tmp" - -# for GCC, use "# xx foo.c". For MSVC, use "#line xx foo.c" -if [ "$_MSVC" != "" ]; then - LINEOPT="line" - OUTFLAG="/Fe" - OUTEXT=".exe" -else - LINEOPT="" - OUTFLAG="-o " - OUTEXT=".exe" # So that I can delete the executables -fi - -# Start it in the right directory -# cd "$CILLYHOME/test/small2" || exit - -# read how many failure cases are in the file; expect line of form -# "// NUMERRORS n" -numcases=`grep NUMERRORS "$srcfile" | perl -e '$_ = <>; m|(\d+)|; print $1;'` -if [ -z "$numcases" ]; then - echo "didn't find a string of form NUMERRORS in the file" - exit 2 -fi -echo "there are $numcases failure cases in this file" - - -# iterate through the cases; first case (0) is where no errors are present -i=0 -if [ "$RUNONLY" != "" ] ;then - i=$RUNONLY -fi -while [ $i -le $numcases ]; do - echo - echo - echo "********************** Iteration $i" - echo - echo - # generate a temporary file; first hide the ERROR tags which identify - # the current test, then remove all remaining ERROR lines - # (syntax for errors has parentheses so if I have >=10 cases I don't - # run into problems where e.g. ERROR1 is a substring of ERROR10) - # use the little perl script to put line number directives where we remove - # lines - echo "generating test $i" - rm -f $tmpname.c 2>/dev/null - ( echo "#define ERROR $i"; echo "#$LINEOPT 1 \"$srcfile\"";cat "$srcfile") |\ - sed "s|ERROR($i)|(selected: $i)|" | \ - perl -e 'my $ln = 0; while(<>) { if($_ =~ m|ERROR\(|) { print "#'$LINEOPT' $ln\n"; } else { print $_; }; $ln ++}' \ - > "$tmpname.c" - chmod a-w "$tmpname.c" - - # Grab the errorline for this test case - themsg=`cat "$srcfile" | grep "ERROR($i).*:" | sed "s/^.*ERROR.*://" ` - if [ "x$themsg" != "x" ] ;then - echo "Expecting error message:$themsg" - fi - - # compile this with our tool - rm -f test-bad.out test-bad.err ${tmpname}$OUTEXT - echo $CILLY $CFLAGS $tmpname.c ${OUTFLAG}${tmpname}$OUTEXT - $CILHOME/bin/teetwo test-bad.out test-bad.err \ - $CILLY $CFLAGS -DERROR=$i $tmpname.c ${OUTFLAG}${tmpname}$OUTEXT - # cat test-bad.out test-bad.err - status=$? - runit=1 - if [ $status != 0 ]; then - if [ $i = 0 ] ;then - echo "The 0th iteration failed to CURE! It is supposed to succeed." - exit $status - else - if [ "x$themsg" != "x" ] ;then - echo "grep \"$themsg\" test-bad.out test-bad.err" - if ! grep "$themsg" test-bad.out test-bad.err ;then - echo "The ${i}th iteration failed to CURE but cannot find: $themsg" - exit 3 - else - echo "The ${i}th iteration failed to CURE, as expected!" - fi - else - echo "The ${i}th iteration failed to CURE. We expected some failure!" - fi - runit=0 - fi - fi - - # run it - if [ $runit != 0 ]; then - echo "./$tmpname$OUTEXT" - rm -f test-bad.out test-bad.err - if $CILHOME/bin/teetwo test-bad.out test-bad.err ./$tmpname$OUTEXT ; then - # cat test-bad.out test-bad.err - if [ $i = 0 ]; then - # expected success on 0th iteration - echo "(succeeded as expected)" - else - # unexpected success on >0th iteration - echo "The ${i}th iteration did not fail! It is supposed to fail." - exit 2 - fi - else - # cat test-bad.out test-bad.err - if [ $i = 0 ]; then - # unexpected failure on 0th iteration - echo "The 0th iteration failed! It is supposed to succeed." - #cat $tmpname.c - exit 2 - else - # expected failure on >0th iteration - if [ "x$themsg" != "x" ] ;then - echo "grep \"$themsg\" test-bad.out test-bad.err" - if ! grep "$themsg" test-bad.out test-bad.err ;then - echo "The ${i}th iteration failed but cannot find:$themsg" - exit 3 - fi - fi - echo "(failed as expected)" - fi - fi - fi - - # possibly bail after 0th - if [ "$TESTBADONCE" != "" ]; then - echo "bailing after 0th iteration because TESTBADONCE is set" - exit 0 - fi - if [ "$RUNONLY" != "" ]; then - echo "bailing after ${RUNONLY}th iteration because RUNONLY is set" - exit 0 - fi - - i=`expr $i + 1` -done - -echo "all $numcases cases in $srcfile failed as expected" - diff --git a/cil/cil.spec b/cil/cil.spec deleted file mode 100644 index 5380973..0000000 --- a/cil/cil.spec +++ /dev/null @@ -1,90 +0,0 @@ -Name: cil -Version: 1.3.5 -Release: 1 -License: BSD -URL: http://manju.cs.berkeley.edu/cil/ -Source0: %{name}-%{version}.tar.gz -BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot -BuildRequires: gcc -BuildRequires: ocaml >= 3.08 -BuildRequires: perl >= 5.6.1 - -# No ELF executables or shared libraries -%define debug_package %{nil} - - -######################################################################## -# -# Package cil -# - -Summary: OCaml library for C program analysis and transformation -Group: Development/Libraries -Requires: perl >= 5.6.1 - -%description -CIL (C Intermediate Language) is a high-level representation along -with a set of tools that permit easy analysis and source-to-source -transformation of C programs. - -This package provides Perl modules which are useful for building -compiler wrappers. A wrapper can use CIL to transform C code before -passing it along to the native C compiler. - -%files -%defattr(-,root,root,-) -%doc LICENSE -%{_datadir}/%{name} - - -######################################################################## -# -# Package cil-devel -# - -%package devel - -Summary: OCaml library for C program analysis and transformation -Group: Development/Libraries -Requires: ocaml >= 3.04 - -%description devel -CIL (C Intermediate Language) is a high-level representation along -with a set of tools that permit easy analysis and source-to-source -transformation of C programs. - -This package provides OCaml interfaces and an OCaml library which form -the CIL API. - -%files devel -%defattr(-,root,root,-) -%doc LICENSE -%{_libdir}/%{name} - - -######################################################################## -# -# General scripts -# - -%prep -%setup -q -n %{name} - -%build -%configure -%define cilmake make -f Makefile.cil -%cilmake cilversion machdep -%cilmake cillib NATIVECAML= -%cilmake cillib NATIVECAML=1 - -%install -rm -rf $RPM_BUILD_ROOT -%makeinstall - -%clean -rm -rf $RPM_BUILD_ROOT - - -%changelog -* Tue Aug 5 2003 Ben Liblit -- Initial build. diff --git a/cil/cil.spec.in b/cil/cil.spec.in deleted file mode 100644 index 0a47dbd..0000000 --- a/cil/cil.spec.in +++ /dev/null @@ -1,90 +0,0 @@ -Name: cil -Version: @CIL_VERSION@ -Release: 1 -License: BSD -URL: http://manju.cs.berkeley.edu/cil/ -Source0: %{name}-%{version}.tar.gz -BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot -BuildRequires: gcc -BuildRequires: ocaml >= 3.08 -BuildRequires: perl >= 5.6.1 - -# No ELF executables or shared libraries -%define debug_package %{nil} - - -######################################################################## -# -# Package cil -# - -Summary: OCaml library for C program analysis and transformation -Group: Development/Libraries -Requires: perl >= 5.6.1 - -%description -CIL (C Intermediate Language) is a high-level representation along -with a set of tools that permit easy analysis and source-to-source -transformation of C programs. - -This package provides Perl modules which are useful for building -compiler wrappers. A wrapper can use CIL to transform C code before -passing it along to the native C compiler. - -%files -%defattr(-,root,root,-) -%doc LICENSE -%{_datadir}/%{name} - - -######################################################################## -# -# Package cil-devel -# - -%package devel - -Summary: OCaml library for C program analysis and transformation -Group: Development/Libraries -Requires: ocaml >= 3.04 - -%description devel -CIL (C Intermediate Language) is a high-level representation along -with a set of tools that permit easy analysis and source-to-source -transformation of C programs. - -This package provides OCaml interfaces and an OCaml library which form -the CIL API. - -%files devel -%defattr(-,root,root,-) -%doc LICENSE -%{_libdir}/%{name} - - -######################################################################## -# -# General scripts -# - -%prep -%setup -q -n %{name} - -%build -%configure -%define cilmake make -f Makefile.cil -%cilmake cilversion machdep -%cilmake cillib NATIVECAML= -%cilmake cillib NATIVECAML=1 - -%install -rm -rf $RPM_BUILD_ROOT -%makeinstall - -%clean -rm -rf $RPM_BUILD_ROOT - - -%changelog -* Tue Aug 5 2003 Ben Liblit -- Initial build. diff --git a/cil/config.guess b/cil/config.guess deleted file mode 100755 index c085f4f..0000000 --- a/cil/config.guess +++ /dev/null @@ -1,1497 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, -# Inc. - -timestamp='2006-05-13' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA -# 02110-1301, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - - -# Originally written by Per Bothner . -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# The plan is that this can be called by configure scripts if you -# don't specify an explicit build system type. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - -trap 'exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. Note that the use of a -# compiler to aid in system detection is discouraged as it requires -# temporary files to be created and, as you can see below, it is a -# headache to deal with in a portable fashion. - -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -# Portable tmp directory creation inspired by the Autoconf team. - -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ; set_cc_for_build= ;' - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or - # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # - # Note: NetBSD doesn't particularly care about the vendor - # portion of the name. We always set it to "unknown". - sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` - case "${UNAME_MACHINE_ARCH}" in - armeb) machine=armeb-unknown ;; - arm*) machine=arm-unknown ;; - sh3el) machine=shl-unknown ;; - sh3eb) machine=sh-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in - arm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep __ELF__ >/dev/null - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # The OS release - # Debian GNU/NetBSD machines have a different userland, and - # thus, need a distinct triplet. However, they do not need - # kernel version information, so it can be replaced with a - # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in - Debian*) - release='-gnu' - ;; - *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - ;; - esac - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit ;; - *:OpenBSD:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} - exit ;; - *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} - exit ;; - *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} - exit ;; - macppc:MirBSD:*:*) - echo powerppc-unknown-mirbsd${UNAME_RELEASE} - exit ;; - *:MirBSD:*:*) - echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} - exit ;; - alpha:OSF1:*:*) - case $UNAME_RELEASE in - *4.0) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - ;; - *5.*) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` - ;; - esac - # According to Compaq, /usr/sbin/psrinfo has been available on - # OSF/1 and Tru64 systems produced since 1995. I hope that - # covers most systems running today. This code pipes the CPU - # types through head -n 1, so we only detect the type of CPU 0. - ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` - case "$ALPHA_CPU_TYPE" in - "EV4 (21064)") - UNAME_MACHINE="alpha" ;; - "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; - "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; - "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; - "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; - "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; - "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; - "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; - "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; - "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; - "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; - "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; - "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; - esac - # A Pn.n version is a patched version. - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - exit ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit ;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit ;; - *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos - exit ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit ;; - *:z/VM:*:*) - echo s390-ibm-zvmoe - exit ;; - *:OS400:*:*) - echo powerpc-ibm-os400 - exit ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit ;; - arm:riscos:*:*|arm:RISCOS:*:*) - echo arm-unknown-riscos - exit ;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit ;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit ;; - DRS?6000:unix:4.0:6*) - echo sparc-icl-nx6 - exit ;; - DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) - case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7; exit ;; - esac ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - i86pc:SunOS:5.*:*) - echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit ;; - m68k:machten:*:*) - echo m68k-apple-machten${UNAME_RELEASE} - exit ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && - dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && - SYSTEM_NAME=`$dummy $dummyarg` && - { echo "$SYSTEM_NAME"; exit; } - echo mips-mips-riscos${UNAME_RELEASE} - exit ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit ;; - Motorola:*:4.3:PL8-*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit ;; - ia64:AIX:*:*) - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` - then - echo "$SYSTEM_NAME" - else - echo rs6000-ibm-aix3.2.5 - fi - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit ;; - *:AIX:*:[45]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac - fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` - test -z "$HP_ARCH" && HP_ARCH=hppa - fi ;; - esac - if [ ${HP_ARCH} = "hppa2.0w" ] - then - eval $set_cc_for_build - - # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating - # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler - # generating 64-bit code. GNU and HP use different nomenclature: - # - # $ CC_FOR_BUILD=cc ./config.guess - # => hppa2.0w-hp-hpux11.23 - # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess - # => hppa64-hp-hpux11.23 - - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | - grep __LP64__ >/dev/null - then - HP_ARCH="hppa2.0w" - else - HP_ARCH="hppa64" - fi - fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit ;; - 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - echo unknown-hitachi-hiuxwe2 - exit ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit ;; - *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ - -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - *:UNICOS/mp:*:*) - echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` - echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:FreeBSD:*:*) - case ${UNAME_MACHINE} in - pc98) - echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - esac - exit ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; - i*:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 - exit ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit ;; - x86:Interix*:[345]*) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - EM64T:Interix*:[345]*) - echo x86_64-unknown-interix${UNAME_RELEASE} - exit ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit ;; - amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) - echo x86_64-unknown-cygwin - exit ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - *:GNU:*:*) - # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit ;; - *:GNU/*:*:*) - # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; - arm*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - cris:Linux:*:*) - echo cris-axis-linux-gnu - exit ;; - crisv32:Linux:*:*) - echo crisv32-axis-linux-gnu - exit ;; - frv:Linux:*:*) - echo frv-unknown-linux-gnu - exit ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - mips:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips - #undef mipsel - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mipsel - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips - #else - CPU= - #endif - #endif -EOF - eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' - /^CPU/{ - s: ::g - p - }'`" - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } - ;; - mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips64 - #undef mips64el - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mips64el - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips64 - #else - CPU= - #endif - #endif -EOF - eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' - /^CPU/{ - s: ::g - p - }'`" - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } - ;; - or32:Linux:*:*) - echo or32-unknown-linux-gnu - exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-gnu - exit ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-gnu - exit ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null - if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} - exit ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-gnu ;; - PA8*) echo hppa2.0-unknown-linux-gnu ;; - *) echo hppa-unknown-linux-gnu ;; - esac - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux - exit ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-gnu - exit ;; - x86_64:Linux:*:*) - echo x86_64-unknown-linux-gnu - exit ;; - i*86:Linux:*:*) - # The BFD linker knows what the default object file format is, so - # first see if it will tell us. cd to the root directory to prevent - # problems with other programs or directories called `ld' in the path. - # Set LC_ALL=C to ensure ld outputs messages in English. - ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ - | sed -ne '/supported targets:/!d - s/[ ][ ]*/ /g - s/.*supported targets: *// - s/ .*// - p'` - case "$ld_supported_targets" in - elf32-i386) - TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" - ;; - a.out-i386-linux) - echo "${UNAME_MACHINE}-pc-linux-gnuaout" - exit ;; - coff-i386) - echo "${UNAME_MACHINE}-pc-linux-gnucoff" - exit ;; - "") - # Either a pre-BFD a.out linker (linux-gnuoldld) or - # one that does not give us useful --help. - echo "${UNAME_MACHINE}-pc-linux-gnuoldld" - exit ;; - esac - # Determine whether the default compiler is a.out or elf - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - #ifdef __ELF__ - # ifdef __GLIBC__ - # if __GLIBC__ >= 2 - LIBC=gnu - # else - LIBC=gnulibc1 - # endif - # else - LIBC=gnulibc1 - # endif - #else - #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC) - LIBC=gnu - #else - LIBC=gnuaout - #endif - #endif - #ifdef __dietlibc__ - LIBC=dietlibc - #endif -EOF - eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' - /^LIBC/{ - s: ::g - p - }'`" - test x"${LIBC}" != x && { - echo "${UNAME_MACHINE}-pc-linux-${LIBC}" - exit - } - test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; } - ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. - # earlier versions are messed up and put the nodename in both - # sysname and nodename. - echo i386-sequent-sysv4 - exit ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit ;; - i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop - exit ;; - i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos - exit ;; - i*86:syllable:*:*) - echo ${UNAME_MACHINE}-pc-syllable - exit ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit ;; - i*86:*:5:[678]*) - # UnixWare 7.x, OpenUNIX and OpenServer 6. - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` - (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i386. - echo i386-pc-msdosdjgpp - exit ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit ;; - mc68k:UNIX:SYSTEM5:3.51m) - echo m68k-convergent-sysv - exit ;; - M680?0:D-NIX:5.3:*) - echo m68k-diab-dnix - exit ;; - M68*:*:R3V[5678]*:*) - test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; - 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4; exit; } ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit ;; - i*86:VOS:*:*) - # From Paul.Green@stratus.com. - echo ${UNAME_MACHINE}-stratus-vos - exit ;; - *:VOS:*:*) - # From Paul.Green@stratus.com. - echo hppa1.1-stratus-vos - exit ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit ;; - SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} - exit ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Darwin:*:*) - UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown - case $UNAME_PROCESSOR in - unknown) UNAME_PROCESSOR=powerpc ;; - esac - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then - UNAME_PROCESSOR=i386 - UNAME_MACHINE=pc - fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit ;; - NSE-?:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} - exit ;; - NSR-?:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit ;; - SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit ;; - *:DragonFly:*:*) - echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit ;; - *:*VMS:*:*) - UNAME_MACHINE=`(uname -p) 2>/dev/null` - case "${UNAME_MACHINE}" in - A*) echo alpha-dec-vms ; exit ;; - I*) echo ia64-dec-vms ; exit ;; - V*) echo vax-dec-vms ; exit ;; - esac ;; - *:XENIX:*:SysV) - echo i386-pc-xenix - exit ;; - i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' - exit ;; - i*86:rdos:*:*) - echo ${UNAME_MACHINE}-pc-rdos - exit ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/cil/config.h.in b/cil/config.h.in deleted file mode 100644 index 57dc9f0..0000000 --- a/cil/config.h.in +++ /dev/null @@ -1,23 +0,0 @@ -#undef HAVE_WCHAR_T - -#undef HAVE_STDLIB_H - -#undef HAVE_STRINGS_H - -#undef HAVE_SYS_TIME_H - -#undef HAVE_UNISTD_H - -#undef HAVE_CONST - -#undef HAVE_INLINE - -#undef HAVE_TIME_H - -#undef HAVE_MEMCP - -#undef HAVE_MKDIR - -#undef HAVE_SELECT - -#undef HAVE_SOCKET diff --git a/cil/config.sub b/cil/config.sub deleted file mode 100755 index f0675aa..0000000 --- a/cil/config.sub +++ /dev/null @@ -1,1469 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002 Free Software Foundation, Inc. - -timestamp='2002-11-30' - -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. - -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit 0 ;; - --version | -v ) - echo "$version" ; exit 0 ;; - --help | --h* | -h ) - echo "$usage"; exit 0 ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit 0;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | freebsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis) - os= - basic_machine=$1 - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ - | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | fr30 | frv \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | i370 | i860 | i960 | ia64 \ - | ip2k \ - | m32r | m68000 | m68k | m88k | mcore \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ - | mips64vr | mips64vrel \ - | mips64orion | mips64orionel \ - | mips64vr4100 | mips64vr4100el \ - | mips64vr4300 | mips64vr4300el \ - | mips64vr5000 | mips64vr5000el \ - | mipsisa32 | mipsisa32el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | ns16k | ns32k \ - | openrisc | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ - | pyramid \ - | sh | sh[1234] | sh3e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ - | sh64 | sh64le \ - | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ - | strongarm \ - | tahoe | thumb | tic80 | tron \ - | v850 | v850e \ - | we32k \ - | x86 | xscale | xstormy16 | xtensa \ - | z8k) - basic_machine=$basic_machine-unknown - ;; - m6811 | m68hc11 | m6812 | m68hc12) - # Motorola 68HC11/12. - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* \ - | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* \ - | clipper-* | cydra-* \ - | d10v-* | d30v-* | dlx-* \ - | elxsi-* \ - | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ - | h8300-* | h8500-* \ - | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* \ - | m32r-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | mcore-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ - | mips64vr-* | mips64vrel-* \ - | mips64orion-* | mips64orionel-* \ - | mips64vr4100-* | mips64vr4100el-* \ - | mips64vr4300-* | mips64vr4300el-* \ - | mips64vr5000-* | mips64vr5000el-* \ - | mipsisa32-* | mipsisa32el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipstx39 | mipstx39el \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ - | pyramid-* \ - | romp-* | rs6000-* \ - | sh-* | sh[1234]-* | sh3e-* | sh[34]eb-* | shbe-* \ - | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ - | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ - | tahoe-* | thumb-* | tic30-* | tic4x-* | tic54x-* | tic80-* | tron-* \ - | v850-* | v850e-* | vax-* \ - | we32k-* \ - | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ - | xtensa-* \ - | ymp-* \ - | z8k-*) - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - c90) - basic_machine=c90-cray - os=-unicos - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | j90) - basic_machine=j90-cray - os=-unicos - ;; - crds | unos) - basic_machine=m68k-crds - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - decsystem10* | dec10*) - basic_machine=pdp10-dec - os=-tops10 - ;; - decsystem20* | dec20*) - basic_machine=pdp10-dec - os=-tops20 - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; -# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - mmix*) - basic_machine=mmix-knuth - os=-mmixware - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - morphos) - basic_machine=powerpc-unknown - os=-morphos - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - or32 | or32-*) - basic_machine=or32-unknown - os=-coff - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pentium | p5 | k5 | k6 | nexgen | viac3) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon | athlon_*) - basic_machine=i686-pc - ;; - pentiumii | pentium2) - basic_machine=i686-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc) basic_machine=powerpc-unknown - ;; - ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64) basic_machine=powerpc64-unknown - ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) - basic_machine=powerpc64le-unknown - ;; - ppc64le-* | powerpc64little-*) - basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - s390 | s390-*) - basic_machine=s390-ibm - ;; - s390x | s390x-*) - basic_machine=s390x-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sb1) - basic_machine=mipsisa64sb1-unknown - ;; - sb1el) - basic_machine=mipsisa64sb1el-unknown - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sparclite-wrs | simso-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3d) - basic_machine=alpha-cray - os=-unicos - ;; - t3e) - basic_machine=alphaev5-cray - os=-unicos - ;; - t90) - basic_machine=t90-cray - os=-unicos - ;; - tic4x | c4x*) - basic_machine=tic4x-unknown - os=-coff - ;; - tic54x | c54x*) - basic_machine=tic54x-unknown - os=-coff - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - toad1) - basic_machine=pdp10-xkl - os=-tops20 - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - ymp) - basic_machine=ymp-cray - os=-unicos - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - romp) - basic_machine=romp-ibm - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh3 | sh4 | sh3eb | sh4eb | sh[1234]le | sh3ele) - basic_machine=sh-unknown - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparc | sparcv9 | sparcv9b) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ - | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* \ - | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ - | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ - | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto-qnx*) - ;; - -nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -atheos*) - os=-atheos - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -nova*) - os=-rtmk-nova - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - # This must come before the *-dec entry. - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - # This also exists in the configure program, but was not the - # default. - # os=-sunos4 - ;; - m68*-cisco) - os=-aout - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - or32-*) - os=-coff - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-ibm) - os=-aix - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -vxsim* | -vxworks* | -windiss*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - -vos*) - vendor=stratus - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit 0 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/cil/configure b/cil/configure deleted file mode 100755 index fe8634b..0000000 --- a/cil/configure +++ /dev/null @@ -1,5697 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.59. -# -# Copyright (C) 2003 Free Software Foundation, Inc. -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## --------------------- ## -## M4sh Initialization. ## -## --------------------- ## - -# Be Bourne compatible -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then - emulate sh - NULLCMD=: - # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' -elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then - set -o posix -fi -DUALCASE=1; export DUALCASE # for MKS sh - -# Support unset when possible. -if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then - as_unset=unset -else - as_unset=false -fi - - -# Work around bugs in pre-3.0 UWIN ksh. -$as_unset ENV MAIL MAILPATH -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -for as_var in \ - LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ - LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ - LC_TELEPHONE LC_TIME -do - if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then - eval $as_var=C; export $as_var - else - $as_unset $as_var - fi -done - -# Required to use basename. -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - - -# Name of the executable. -as_me=`$as_basename "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)$' \| \ - . : '\(.\)' 2>/dev/null || -echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } - /^X\/\(\/\/\)$/{ s//\1/; q; } - /^X\/\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - - -# PATH needs CR, and LINENO needs CR and PATH. -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - echo "#! /bin/sh" >conf$$.sh - echo "exit 0" >>conf$$.sh - chmod +x conf$$.sh - if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then - PATH_SEPARATOR=';' - else - PATH_SEPARATOR=: - fi - rm -f conf$$.sh -fi - - - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" || { - # Find who we are. Look in the path if we contain no path at all - # relative or not. - case $0 in - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break -done - - ;; - esac - # We did not find ourselves, most probably we were run as `sh COMMAND' - # in which case we are not to be found in the path. - if test "x$as_myself" = x; then - as_myself=$0 - fi - if test ! -f "$as_myself"; then - { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 - { (exit 1); exit 1; }; } - fi - case $CONFIG_SHELL in - '') - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for as_base in sh bash ksh sh5; do - case $as_dir in - /*) - if ("$as_dir/$as_base" -c ' - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then - $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } - $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } - CONFIG_SHELL=$as_dir/$as_base - export CONFIG_SHELL - exec "$CONFIG_SHELL" "$0" ${1+"$@"} - fi;; - esac - done -done -;; - esac - - # Create $as_me.lineno as a copy of $as_myself, but with $LINENO - # uniformly replaced by the line number. The first 'sed' inserts a - # line-number line before each line; the second 'sed' does the real - # work. The second script uses 'N' to pair each line-number line - # with the numbered line, and appends trailing '-' during - # substitution so that $LINENO is not a special case at line end. - # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the - # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) - sed '=' <$as_myself | - sed ' - N - s,$,-, - : loop - s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, - t loop - s,-$,, - s,^['$as_cr_digits']*\n,, - ' >$as_me.lineno && - chmod +x $as_me.lineno || - { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 - { (exit 1); exit 1; }; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensible to this). - . ./$as_me.lineno - # Exit status is that of the last command. - exit -} - - -case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in - *c*,-n*) ECHO_N= ECHO_C=' -' ECHO_T=' ' ;; - *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; - *) ECHO_N= ECHO_C='\c' ECHO_T= ;; -esac - -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -rm -f conf$$ conf$$.exe conf$$.file -echo >conf$$.file -if ln -s conf$$.file conf$$ 2>/dev/null; then - # We could just check for DJGPP; but this test a) works b) is more generic - # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). - if test -f conf$$.exe; then - # Don't use ln at all; we don't have any links - as_ln_s='cp -p' - else - as_ln_s='ln -s' - fi -elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.file - -if mkdir -p . 2>/dev/null; then - as_mkdir_p=: -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_executable_p="test -f" - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -# IFS -# We need space, tab and new line, in precisely that order. -as_nl=' -' -IFS=" $as_nl" - -# CDPATH. -$as_unset CDPATH - - -# Name of the host. -# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -exec 6>&1 - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_config_libobj_dir=. -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= -SHELL=${CONFIG_SHELL-/bin/sh} - -# Maximum number of lines to put in a shell here document. -# This variable seems obsolete. It should probably be removed, and -# only ac_max_sed_lines should be used. -: ${ac_max_here_lines=38} - -# Identity of this package. -PACKAGE_NAME= -PACKAGE_TARNAME= -PACKAGE_VERSION= -PACKAGE_STRING= -PACKAGE_BUGREPORT= - -ac_unique_file="src/cil.mli" -# Factoring default headers for most tests. -ac_includes_default="\ -#include -#if HAVE_SYS_TYPES_H -# include -#endif -#if HAVE_SYS_STAT_H -# include -#endif -#if STDC_HEADERS -# include -# include -#else -# if HAVE_STDLIB_H -# include -# endif -#endif -#if HAVE_STRING_H -# if !STDC_HEADERS && HAVE_MEMORY_H -# include -# endif -# include -#endif -#if HAVE_STRINGS_H -# include -#endif -#if HAVE_INTTYPES_H -# include -#else -# if HAVE_STDINT_H -# include -# endif -#endif -#if HAVE_UNISTD_H -# include -#endif" - -ac_subst_vars='CIL_FEATURES_DEFINES NEWLINE SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os CPP EGREP LIBOBJS ARCHOS CILHOME HAS_MSVC DEFAULT_COMPILER DEFAULT_CIL_MODE CIL_VERSION_MAJOR CIL_VERSION_MINOR CIL_VERSION_REV CIL_VERSION CYCLES_PER_USEC HAS_PERFCOUNT HAVE_BUILTIN_VA_LIST THREAD_IS_KEYWORD UNDERSCORE_NAME EXTRAFEATURES EXTRASRCDIRS LTLIBOBJS' -ac_subst_files='' - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -ac_prev= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case $ac_option in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid feature name: $ac_feature" >&2 - { (exit 1); exit 1; }; } - ac_feature=`echo $ac_feature | sed 's/-/_/g'` - eval "enable_$ac_feature=no" ;; - - -enable-* | --enable-*) - ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid feature name: $ac_feature" >&2 - { (exit 1); exit 1; }; } - ac_feature=`echo $ac_feature | sed 's/-/_/g'` - case $ac_option in - *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; - *) ac_optarg=yes ;; - esac - eval "enable_$ac_feature='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid package name: $ac_package" >&2 - { (exit 1); exit 1; }; } - ac_package=`echo $ac_package| sed 's/-/_/g'` - case $ac_option in - *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; - *) ac_optarg=yes ;; - esac - eval "with_$ac_package='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid package name: $ac_package" >&2 - { (exit 1); exit 1; }; } - ac_package=`echo $ac_package | sed 's/-/_/g'` - eval "with_$ac_package=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) { echo "$as_me: error: unrecognized option: $ac_option -Try \`$0 --help' for more information." >&2 - { (exit 1); exit 1; }; } - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && - { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 - { (exit 1); exit 1; }; } - ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` - eval "$ac_envvar='$ac_optarg'" - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - echo "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - { echo "$as_me: error: missing argument to $ac_option" >&2 - { (exit 1); exit 1; }; } -fi - -# Be sure to have absolute paths. -for ac_var in exec_prefix prefix -do - eval ac_val=$`echo $ac_var` - case $ac_val in - [\\/$]* | ?:[\\/]* | NONE | '' ) ;; - *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 - { (exit 1); exit 1; }; };; - esac -done - -# Be sure to have absolute paths. -for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ - localstatedir libdir includedir oldincludedir infodir mandir -do - eval ac_val=$`echo $ac_var` - case $ac_val in - [\\/$]* | ?:[\\/]* ) ;; - *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 - { (exit 1); exit 1; }; };; - esac -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used." >&2 - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_confdir=`(dirname "$0") 2>/dev/null || -$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$0" : 'X\(//\)[^/]' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$0" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 - { (exit 1); exit 1; }; } - else - { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 - { (exit 1); exit 1; }; } - fi -fi -(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || - { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 - { (exit 1); exit 1; }; } -srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` -ac_env_build_alias_set=${build_alias+set} -ac_env_build_alias_value=$build_alias -ac_cv_env_build_alias_set=${build_alias+set} -ac_cv_env_build_alias_value=$build_alias -ac_env_host_alias_set=${host_alias+set} -ac_env_host_alias_value=$host_alias -ac_cv_env_host_alias_set=${host_alias+set} -ac_cv_env_host_alias_value=$host_alias -ac_env_target_alias_set=${target_alias+set} -ac_env_target_alias_value=$target_alias -ac_cv_env_target_alias_set=${target_alias+set} -ac_cv_env_target_alias_value=$target_alias -ac_env_CC_set=${CC+set} -ac_env_CC_value=$CC -ac_cv_env_CC_set=${CC+set} -ac_cv_env_CC_value=$CC -ac_env_CFLAGS_set=${CFLAGS+set} -ac_env_CFLAGS_value=$CFLAGS -ac_cv_env_CFLAGS_set=${CFLAGS+set} -ac_cv_env_CFLAGS_value=$CFLAGS -ac_env_LDFLAGS_set=${LDFLAGS+set} -ac_env_LDFLAGS_value=$LDFLAGS -ac_cv_env_LDFLAGS_set=${LDFLAGS+set} -ac_cv_env_LDFLAGS_value=$LDFLAGS -ac_env_CPPFLAGS_set=${CPPFLAGS+set} -ac_env_CPPFLAGS_value=$CPPFLAGS -ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} -ac_cv_env_CPPFLAGS_value=$CPPFLAGS -ac_env_CPP_set=${CPP+set} -ac_env_CPP_value=$CPP -ac_cv_env_CPP_set=${CPP+set} -ac_cv_env_CPP_value=$CPP - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures this package to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -_ACEOF - - cat <<_ACEOF -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data [PREFIX/share] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --infodir=DIR info documentation [PREFIX/info] - --mandir=DIR man documentation [PREFIX/man] -_ACEOF - - cat <<\_ACEOF - -System types: - --build=BUILD configure for building on BUILD [guessed] - --host=HOST cross-compile to build programs to run on HOST [BUILD] - --target=TARGET configure for building compilers for TARGET [HOST] -_ACEOF -fi - -if test -n "$ac_init_help"; then - - cat <<\_ACEOF - -Optional Packages: - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-blockinggraph enable the blocking graph feature - --with-rand enable the randomized value numbering - --with-arithabs enable the arithmetic abstraction - --with-zrapp enable the zrapp pretty-printer - -Some influential environment variables: - CC C compiler command - CFLAGS C compiler flags - LDFLAGS linker flags, e.g. -L if you have libraries in a - nonstandard directory - CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have - headers in a nonstandard directory - CPP C preprocessor - -Use these variables to override the choices made by `configure' or to help -it to find libraries and programs with nonstandard names/locations. - -_ACEOF -fi - -if test "$ac_init_help" = "recursive"; then - # If there are subdirs, report their specific --help. - ac_popdir=`pwd` - for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d $ac_dir || continue - ac_builddir=. - -if test "$ac_dir" != .; then - ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` - # A "../" for each directory in $ac_dir_suffix. - ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` -else - ac_dir_suffix= ac_top_builddir= -fi - -case $srcdir in - .) # No --srcdir option. We are building in place. - ac_srcdir=. - if test -z "$ac_top_builddir"; then - ac_top_srcdir=. - else - ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` - fi ;; - [\\/]* | ?:[\\/]* ) # Absolute path. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir ;; - *) # Relative path. - ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_builddir$srcdir ;; -esac - -# Do not use `cd foo && pwd` to compute absolute paths, because -# the directories may not exist. -case `pwd` in -.) ac_abs_builddir="$ac_dir";; -*) - case "$ac_dir" in - .) ac_abs_builddir=`pwd`;; - [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; - *) ac_abs_builddir=`pwd`/"$ac_dir";; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_builddir=${ac_top_builddir}.;; -*) - case ${ac_top_builddir}. in - .) ac_abs_top_builddir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; - *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_srcdir=$ac_srcdir;; -*) - case $ac_srcdir in - .) ac_abs_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; - *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_srcdir=$ac_top_srcdir;; -*) - case $ac_top_srcdir in - .) ac_abs_top_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; - *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; - esac;; -esac - - cd $ac_dir - # Check for guested configure; otherwise get Cygnus style configure. - if test -f $ac_srcdir/configure.gnu; then - echo - $SHELL $ac_srcdir/configure.gnu --help=recursive - elif test -f $ac_srcdir/configure; then - echo - $SHELL $ac_srcdir/configure --help=recursive - elif test -f $ac_srcdir/configure.ac || - test -f $ac_srcdir/configure.in; then - echo - $ac_configure --help - else - echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi - cd $ac_popdir - done -fi - -test -n "$ac_init_help" && exit 0 -if $ac_init_version; then - cat <<\_ACEOF - -Copyright (C) 2003 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit 0 -fi -exec 5>config.log -cat >&5 <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by $as_me, which was -generated by GNU Autoconf 2.59. Invocation command line was - - $ $0 $@ - -_ACEOF -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -hostinfo = `(hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - echo "PATH: $as_dir" -done - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_sep= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) - ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; - 2) - ac_configure_args1="$ac_configure_args1 '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" - # Get rid of the leading space. - ac_sep=" " - ;; - esac - done -done -$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } -$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Be sure not to use single quotes in there, as some shells, -# such as our DU 5.0 friend, will then `close' the trap. -trap 'exit_status=$? - # Save into config.log some information that might help in debugging. - { - echo - - cat <<\_ASBOX -## ---------------- ## -## Cache variables. ## -## ---------------- ## -_ASBOX - echo - # The following way of writing the cache mishandles newlines in values, -{ - (set) 2>&1 | - case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in - *ac_space=\ *) - sed -n \ - "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" - ;; - *) - sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" - ;; - esac; -} - echo - - cat <<\_ASBOX -## ----------------- ## -## Output variables. ## -## ----------------- ## -_ASBOX - echo - for ac_var in $ac_subst_vars - do - eval ac_val=$`echo $ac_var` - echo "$ac_var='"'"'$ac_val'"'"'" - done | sort - echo - - if test -n "$ac_subst_files"; then - cat <<\_ASBOX -## ------------- ## -## Output files. ## -## ------------- ## -_ASBOX - echo - for ac_var in $ac_subst_files - do - eval ac_val=$`echo $ac_var` - echo "$ac_var='"'"'$ac_val'"'"'" - done | sort - echo - fi - - if test -s confdefs.h; then - cat <<\_ASBOX -## ----------- ## -## confdefs.h. ## -## ----------- ## -_ASBOX - echo - sed "/^$/d" confdefs.h | sort - echo - fi - test "$ac_signal" != 0 && - echo "$as_me: caught signal $ac_signal" - echo "$as_me: exit $exit_status" - } >&5 - rm -f core *.core && - rm -rf conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status - ' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo >confdefs.h - -# Predefined preprocessor variables. - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_NAME "$PACKAGE_NAME" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_TARNAME "$PACKAGE_TARNAME" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_VERSION "$PACKAGE_VERSION" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_STRING "$PACKAGE_STRING" -_ACEOF - - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" -_ACEOF - - -# Let the site file select an alternate cache file if it wants to. -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 -echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special - # files actually), so we avoid doing that. - if test -f "$cache_file"; then - { echo "$as_me:$LINENO: loading cache $cache_file" >&5 -echo "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . $cache_file;; - *) . ./$cache_file;; - esac - fi -else - { echo "$as_me:$LINENO: creating cache $cache_file" >&5 -echo "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in `(set) 2>&1 | - sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val="\$ac_cv_env_${ac_var}_value" - eval ac_new_val="\$ac_env_${ac_var}_value" - case $ac_old_set,$ac_new_set in - set,) - { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 -echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 -echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 -echo "$as_me: former value: $ac_old_val" >&2;} - { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 -echo "$as_me: current value: $ac_new_val" >&2;} - ac_cache_corrupted=: - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) - ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 -echo "$as_me: error: changes in the environment can compromise the build" >&2;} - { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 -echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} - { (exit 1); exit 1; }; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - - - - - - - - - - - - - - - - - - ac_config_headers="$ac_config_headers config.h" - - -# sm: require a late-enough autoconf; this is the version number -# that's on manju, so I assume it's ok - - -# -# Assign here the CIL version numbers -CIL_VERSION_MAJOR=1 -CIL_VERSION_MINOR=3 -CIL_VERSION_REV=5 -CIL_VERSION=$CIL_VERSION_MAJOR.$CIL_VERSION_MINOR.$CIL_VERSION_REV - - -# make sure I haven't forgotten to run autoconf -if test configure -ot configure.in; then - { { echo "$as_me:$LINENO: error: configure is older than configure.in; you forgot to run autoconf" >&5 -echo "$as_me: error: configure is older than configure.in; you forgot to run autoconf" >&2;} - { (exit 1); exit 1; }; } -fi - -# check for C compiler; this typically finds gcc; it sets the -# variable CC to whatever it finds, which then gets substituted -# for @CC@ in output files; you have to do this even if you don't -# care about @CC@, because system feature tests later on in -# the ./configure script will expect $CC to be set right -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. -set dummy ${ac_tool_prefix}gcc; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="${ac_tool_prefix}gcc" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - echo "$as_me:$LINENO: result: $CC" >&5 -echo "${ECHO_T}$CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - -fi -if test -z "$ac_cv_prog_CC"; then - ac_ct_CC=$CC - # Extract the first word of "gcc", so it can be a program name with args. -set dummy gcc; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_ac_ct_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CC="gcc" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 -echo "${ECHO_T}$ac_ct_CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - - CC=$ac_ct_CC -else - CC="$ac_cv_prog_CC" -fi - -if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. -set dummy ${ac_tool_prefix}cc; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="${ac_tool_prefix}cc" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - echo "$as_me:$LINENO: result: $CC" >&5 -echo "${ECHO_T}$CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - -fi -if test -z "$ac_cv_prog_CC"; then - ac_ct_CC=$CC - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_ac_ct_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CC="cc" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 -echo "${ECHO_T}$ac_ct_CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - - CC=$ac_ct_CC -else - CC="$ac_cv_prog_CC" -fi - -fi -if test -z "$CC"; then - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - ac_prog_rejected=no -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then - ac_prog_rejected=yes - continue - fi - ac_cv_prog_CC="cc" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -if test $ac_prog_rejected = yes; then - # We found a bogon in the path, so make sure we never use it. - set dummy $ac_cv_prog_CC - shift - if test $# != 0; then - # We chose a different compiler from the bogus one. - # However, it has the same basename, so the bogon will be chosen - # first if we set CC to just the basename; use the full file name. - shift - ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" - fi -fi -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - echo "$as_me:$LINENO: result: $CC" >&5 -echo "${ECHO_T}$CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - -fi -if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - for ac_prog in cl - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - echo "$as_me:$LINENO: result: $CC" >&5 -echo "${ECHO_T}$CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - - test -n "$CC" && break - done -fi -if test -z "$CC"; then - ac_ct_CC=$CC - for ac_prog in cl -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -echo "$as_me:$LINENO: checking for $ac_word" >&5 -echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 -if test "${ac_cv_prog_ac_ct_CC+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CC="$ac_prog" - echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done -done - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 -echo "${ECHO_T}$ac_ct_CC" >&6 -else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 -fi - - test -n "$ac_ct_CC" && break -done - - CC=$ac_ct_CC -fi - -fi - - -test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH -See \`config.log' for more details." >&5 -echo "$as_me: error: no acceptable C compiler found in \$PATH -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } - -# Provide some information about the compiler. -echo "$as_me:$LINENO:" \ - "checking for C compiler version" >&5 -ac_compiler=`set X $ac_compile; echo $2` -{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 - (eval $ac_compiler --version &5) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 - (eval $ac_compiler -v &5) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 - (eval $ac_compiler -V &5) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } - -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.exe b.out" -# Try to create an executable without -o first, disregard a.out. -# It will help us diagnose broken compilers, and finding out an intuition -# of exeext. -echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 -echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 -ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` -if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 - (eval $ac_link_default) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - # Find the output, starting from the most likely. This scheme is -# not robust to junk in `.', hence go to wildcards (a.*) only as a last -# resort. - -# Be careful to initialize this variable, since it used to be cached. -# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. -ac_cv_exeext= -# b.out is created by i960 compilers. -for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out -do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) - ;; - conftest.$ac_ext ) - # This is the source file. - ;; - [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; - *.* ) - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - # FIXME: I believe we export ac_cv_exeext for Libtool, - # but it would be cool to find out if it's true. Does anybody - # maintain Libtool? --akim. - export ac_cv_exeext - break;; - * ) - break;; - esac -done -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { echo "$as_me:$LINENO: error: C compiler cannot create executables -See \`config.log' for more details." >&5 -echo "$as_me: error: C compiler cannot create executables -See \`config.log' for more details." >&2;} - { (exit 77); exit 77; }; } -fi - -ac_exeext=$ac_cv_exeext -echo "$as_me:$LINENO: result: $ac_file" >&5 -echo "${ECHO_T}$ac_file" >&6 - -# Check the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -echo "$as_me:$LINENO: checking whether the C compiler works" >&5 -echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 -# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 -# If not cross compiling, check that we can run a simple program. -if test "$cross_compiling" != yes; then - if { ac_try='./$ac_file' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { echo "$as_me:$LINENO: error: cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } - fi - fi -fi -echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 - -rm -f a.out a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -# Check the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 -echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 -echo "$as_me:$LINENO: result: $cross_compiling" >&5 -echo "${ECHO_T}$cross_compiling" >&6 - -echo "$as_me:$LINENO: checking for suffix of executables" >&5 -echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. -for ac_file in conftest.exe conftest conftest.*; do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; - *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - export ac_cv_exeext - break;; - * ) break;; - esac -done -else - { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -fi - -rm -f conftest$ac_cv_exeext -echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 -echo "${ECHO_T}$ac_cv_exeext" >&6 - -rm -f conftest.$ac_ext -EXEEXT=$ac_cv_exeext -ac_exeext=$EXEEXT -echo "$as_me:$LINENO: checking for suffix of object files" >&5 -echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 -if test "${ac_cv_objext+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.o conftest.obj -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then - for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; - *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` - break;; - esac -done -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile -See \`config.log' for more details." >&5 -echo "$as_me: error: cannot compute suffix of object files: cannot compile -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -fi - -rm -f conftest.$ac_cv_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 -echo "${ECHO_T}$ac_cv_objext" >&6 -OBJEXT=$ac_cv_objext -ac_objext=$OBJEXT -echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 -echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 -if test "${ac_cv_c_compiler_gnu+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ -#ifndef __GNUC__ - choke me -#endif - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_compiler_gnu=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_compiler_gnu=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_c_compiler_gnu=$ac_compiler_gnu - -fi -echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 -echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 -GCC=`test $ac_compiler_gnu = yes && echo yes` -ac_test_CFLAGS=${CFLAGS+set} -ac_save_CFLAGS=$CFLAGS -CFLAGS="-g" -echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 -echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 -if test "${ac_cv_prog_cc_g+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_prog_cc_g=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_prog_cc_g=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 -echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 -if test "$ac_test_CFLAGS" = set; then - CFLAGS=$ac_save_CFLAGS -elif test $ac_cv_prog_cc_g = yes; then - if test "$GCC" = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-g" - fi -else - if test "$GCC" = yes; then - CFLAGS="-O2" - else - CFLAGS= - fi -fi -echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 -echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 -if test "${ac_cv_prog_cc_stdc+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_cv_prog_cc_stdc=no -ac_save_CC=$CC -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#include -#include -#include -/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ -struct buf { int x; }; -FILE * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (p, i) - char **p; - int i; -{ - return p[i]; -} -static char *f (char * (*g) (char **, int), char **p, ...) -{ - char *s; - va_list v; - va_start (v,p); - s = g (p, va_arg (v,int)); - va_end (v); - return s; -} - -/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has - function prototypes and stuff, but not '\xHH' hex character constants. - These don't provoke an error unfortunately, instead are silently treated - as 'x'. The following induces an error, until -std1 is added to get - proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an - array size at least. It's necessary to write '\x00'==0 to get something - that's true only with -std1. */ -int osf4_cc_array ['\x00' == 0 ? 1 : -1]; - -int test (int i, double x); -struct s1 {int (*f) (int a);}; -struct s2 {int (*f) (double a);}; -int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); -int argc; -char **argv; -int -main () -{ -return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; - ; - return 0; -} -_ACEOF -# Don't try gcc -ansi; that turns off useful extensions and -# breaks some systems' header files. -# AIX -qlanglvl=ansi -# Ultrix and OSF/1 -std1 -# HP-UX 10.20 and later -Ae -# HP-UX older versions -Aa -D_HPUX_SOURCE -# SVR4 -Xc -D__EXTENSIONS__ -for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" -do - CC="$ac_save_CC $ac_arg" - rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_prog_cc_stdc=$ac_arg -break -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -fi -rm -f conftest.err conftest.$ac_objext -done -rm -f conftest.$ac_ext conftest.$ac_objext -CC=$ac_save_CC - -fi - -case "x$ac_cv_prog_cc_stdc" in - x|xno) - echo "$as_me:$LINENO: result: none needed" >&5 -echo "${ECHO_T}none needed" >&6 ;; - *) - echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 -echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 - CC="$CC $ac_cv_prog_cc_stdc" ;; -esac - -# Some people use a C++ compiler to compile C. Since we use `exit', -# in C++ we need to declare it. In case someone uses the same compiler -# for both compiling C and C++ we need to have the C++ compiler decide -# the declaration of exit, since it's the most demanding environment. -cat >conftest.$ac_ext <<_ACEOF -#ifndef __cplusplus - choke me -#endif -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - for ac_declaration in \ - '' \ - 'extern "C" void std::exit (int) throw (); using std::exit;' \ - 'extern "C" void std::exit (int); using std::exit;' \ - 'extern "C" void exit (int) throw ();' \ - 'extern "C" void exit (int);' \ - 'void exit (int);' -do - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_declaration -#include -int -main () -{ -exit (42); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - : -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -continue -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_declaration -int -main () -{ -exit (42); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - break -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -done -rm -f conftest* -if test -n "$ac_declaration"; then - echo '#ifdef __cplusplus' >>confdefs.h - echo $ac_declaration >>confdefs.h - echo '#endif' >>confdefs.h -fi - -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -ac_aux_dir= -for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - elif test -f $ac_dir/shtool; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/shtool install -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&5 -echo "$as_me: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&2;} - { (exit 1); exit 1; }; } -fi -ac_config_guess="$SHELL $ac_aux_dir/config.guess" -ac_config_sub="$SHELL $ac_aux_dir/config.sub" -ac_configure="$SHELL $ac_aux_dir/configure" # This should be Cygnus configure. - -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AmigaOS /C/install, which installs bootblocks on floppy discs -# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# OS/2's system install, which has a completely different semantic -# ./install, which can be erroneously created by make from ./install.sh. -echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 -echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6 -if test -z "$INSTALL"; then -if test "${ac_cv_path_install+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - # Account for people who put trailing slashes in PATH elements. -case $as_dir/ in - ./ | .// | /cC/* | \ - /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ - ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ - /usr/ucb/* ) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - # Don't use installbsd from OSF since it installs stuff as root - # by default. - for ac_prog in ginstall scoinst install; do - for ac_exec_ext in '' $ac_executable_extensions; do - if $as_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then - if test $ac_prog = install && - grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - : - elif test $ac_prog = install && - grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then - # program-specific install script used by HP pwplus--don't use. - : - else - ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" - break 3 - fi - fi - done - done - ;; -esac -done - - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL=$ac_cv_path_install - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL=$ac_install_sh - fi -fi -echo "$as_me:$LINENO: result: $INSTALL" >&5 -echo "${ECHO_T}$INSTALL" >&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - - - -# find system type (using this macro means we must include -# the files install-sh, config.sub, and config.guess (all from -# the autoconf distribution) in our source tree!) -# Make sure we can run config.sub. -$ac_config_sub sun4 >/dev/null 2>&1 || - { { echo "$as_me:$LINENO: error: cannot run $ac_config_sub" >&5 -echo "$as_me: error: cannot run $ac_config_sub" >&2;} - { (exit 1); exit 1; }; } - -echo "$as_me:$LINENO: checking build system type" >&5 -echo $ECHO_N "checking build system type... $ECHO_C" >&6 -if test "${ac_cv_build+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_cv_build_alias=$build_alias -test -z "$ac_cv_build_alias" && - ac_cv_build_alias=`$ac_config_guess` -test -z "$ac_cv_build_alias" && - { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5 -echo "$as_me: error: cannot guess build type; you must specify one" >&2;} - { (exit 1); exit 1; }; } -ac_cv_build=`$ac_config_sub $ac_cv_build_alias` || - { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_build_alias failed" >&5 -echo "$as_me: error: $ac_config_sub $ac_cv_build_alias failed" >&2;} - { (exit 1); exit 1; }; } - -fi -echo "$as_me:$LINENO: result: $ac_cv_build" >&5 -echo "${ECHO_T}$ac_cv_build" >&6 -build=$ac_cv_build -build_cpu=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` -build_vendor=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` -build_os=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` - - -echo "$as_me:$LINENO: checking host system type" >&5 -echo $ECHO_N "checking host system type... $ECHO_C" >&6 -if test "${ac_cv_host+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_cv_host_alias=$host_alias -test -z "$ac_cv_host_alias" && - ac_cv_host_alias=$ac_cv_build_alias -ac_cv_host=`$ac_config_sub $ac_cv_host_alias` || - { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_host_alias failed" >&5 -echo "$as_me: error: $ac_config_sub $ac_cv_host_alias failed" >&2;} - { (exit 1); exit 1; }; } - -fi -echo "$as_me:$LINENO: result: $ac_cv_host" >&5 -echo "${ECHO_T}$ac_cv_host" >&6 -host=$ac_cv_host -host_cpu=`echo $ac_cv_host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` -host_vendor=`echo $ac_cv_host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` -host_os=`echo $ac_cv_host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` - - -echo "$as_me:$LINENO: checking target system type" >&5 -echo $ECHO_N "checking target system type... $ECHO_C" >&6 -if test "${ac_cv_target+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_cv_target_alias=$target_alias -test "x$ac_cv_target_alias" = "x" && - ac_cv_target_alias=$ac_cv_host_alias -ac_cv_target=`$ac_config_sub $ac_cv_target_alias` || - { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_target_alias failed" >&5 -echo "$as_me: error: $ac_config_sub $ac_cv_target_alias failed" >&2;} - { (exit 1); exit 1; }; } - -fi -echo "$as_me:$LINENO: result: $ac_cv_target" >&5 -echo "${ECHO_T}$ac_cv_target" >&6 -target=$ac_cv_target -target_cpu=`echo $ac_cv_target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` -target_vendor=`echo $ac_cv_target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` -target_os=`echo $ac_cv_target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` - - -# The aliases save the names the user supplied, while $host etc. -# will get canonicalized. -test -n "$target_alias" && - test "$program_prefix$program_suffix$program_transform_name" = \ - NONENONEs,x,x, && - program_prefix=${target_alias}- - - -# ---------------- generic functions ----------------- -# debugging diagnostic; set to 'echo' to debug or 'true' for production -# (technically you're not supposed to use shell functions in -# configure scripts, because some-obscure-sh somewhere doesn't -# support them.. but they're too convenient to not use) -diagnostic() { - #echo "$@" - true "$@" -} - -# determine if a binary is in the path -binaryExists() { - # on cygwin, 'which' always returns success, so use 'type' instead - if type "$1" >/dev/null 2>&1; then - return 0 - else - return 1 - fi -} - - -# -------------- portable configuration ---------------- -# this specifies the root of the source tree; it's just the -# directory where ./configure runs, except on cygwin, which -# overrides this below -CILHOME=`pwd` - -DEFAULT_COMPILER=_GNUCC -DEFAULT_CIL_MODE=GNUCC - -# is the microsoft compiler available? -# hmm.. I think we should check the version or something, because -# sometimes people have Common Lisp's interpreter called 'cl' .. -echo "$as_me:$LINENO: checking for msvc cl.exe (optional)" >&5 -echo $ECHO_N "checking for msvc cl.exe (optional)... $ECHO_C" >&6 -# See if CC points to the MS compiler -if "$CC" 2>&1 | grep "Microsoft" >/dev/null; then - echo "$as_me:$LINENO: result: found, set as default" >&5 -echo "${ECHO_T}found, set as default" >&6 - HAS_MSVC=yes - DEFAULT_COMPILER=_MSVC - DEFAULT_CIL_MODE=MSVC -else - if cl 2>&1 | grep "Microsoft" >/dev/null ;then - echo "$as_me:$LINENO: result: found" >&5 -echo "${ECHO_T}found" >&6 - HAS_MSVC=yes - else - echo "$as_me:$LINENO: result: not found" >&5 -echo "${ECHO_T}not found" >&6 - HAS_MSVC=no - fi -fi - -# is ocaml available? -# needed binaries: ocamllex ocamlyacc ocamldep ocamlopt ocamlc -ocamlDownloadInstructions=" - OCaml can be downloaded from http://caml.inria.fr/ocaml/. - After downloading and unpacking the source distribution, in the ocaml - directory, do - ./configure - make world - make opt - make install - Then come back here and re-run ./configure." - -# required major/minor. -# required major/minor -reqMaj=3 -reqMin=08 -knownMaj=3 -knownMin=09 -echo "$as_me:$LINENO: checking ocaml version is at least $reqMaj.$reqMin" >&5 -echo $ECHO_N "checking ocaml version is at least $reqMaj.$reqMin... $ECHO_C" >&6 -if binaryExists ocamlc; then - # what version? - ver=`ocamlc -v | grep version | sed 's/^.*version //'` - diagnostic "ver is $ver" - # major: anything before the . - major=`echo $ver | sed 's/\..*$//'` - diagnostic "major is $major" - # minor: numbers after the . - # (the outer level of bracket-quotation protects the inner brackets) - minor=`echo $ver | sed 's/^[^.]*\.\([0-9][0-9]*\).*$/\1/'` - diagnostic "minor is $minor" - - # I would think autoconf would already have a facility for doing - # these kinds of major/minor version checks, but I can't find it - if test $major -gt $reqMaj -o $major -ge $reqMaj -a $minor -ge $reqMin; then - echo "$as_me:$LINENO: result: version is $ver, ok" >&5 -echo "${ECHO_T}version is $ver, ok" >&6 - - # sm: added this test when we found that CCured needed to be changed - # a little when 3.06 came out (it had previously worked with 3.04) - if test "$major" -gt $knownMaj -o "$major" -ge $knownMaj -a "$minor" -gt $knownMin; then - { echo "$as_me:$LINENO: WARNING: Your ocaml version is $ver, but the latest version this program - is known to work with is $knownMaj.$knownMin. If you have - trouble compiling, please try using an earlier version - or see if there is a later version of this program." >&5 -echo "$as_me: WARNING: Your ocaml version is $ver, but the latest version this program - is known to work with is $knownMaj.$knownMin. If you have - trouble compiling, please try using an earlier version - or see if there is a later version of this program." >&2;} - fi - else - { { echo "$as_me:$LINENO: error: - I found OCaml version $ver; this program requires at least $reqMaj.$reqMin. - Please download a newer OCaml distribution. - $ocamlDownloadInstructions - " >&5 -echo "$as_me: error: - I found OCaml version $ver; this program requires at least $reqMaj.$reqMin. - Please download a newer OCaml distribution. - $ocamlDownloadInstructions - " >&2;} - { (exit 1); exit 1; }; } - fi - - # check for existence of other binaries - echo "$as_me:$LINENO: checking existence of related ocaml tools" >&5 -echo $ECHO_N "checking existence of related ocaml tools... $ECHO_C" >&6 - if binaryExists ocamllex && \ - binaryExists ocamlyacc && \ - binaryExists ocamldep && \ - binaryExists ocamlopt; then - echo "$as_me:$LINENO: result: ok" >&5 -echo "${ECHO_T}ok" >&6 - else - { { echo "$as_me:$LINENO: error: - At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing. - In particular, ocamlopt requires you to \"make opt\" when building - OCaml from source. Please make sure all these tools are built and - in the path. - " >&5 -echo "$as_me: error: - At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing. - In particular, ocamlopt requires you to \"make opt\" when building - OCaml from source. Please make sure all these tools are built and - in the path. - " >&2;} - { (exit 1); exit 1; }; } - fi -else - { { echo "$as_me:$LINENO: error: - The \"ocamlc\" OCaml compiler was not found in the path: $PATH. - - Most of this program is written in the OCaml language, so its compiler - is required. - $ocamlDownloadInstructions - " >&5 -echo "$as_me: error: - The \"ocamlc\" OCaml compiler was not found in the path: $PATH. - - Most of this program is written in the OCaml language, so its compiler - is required. - $ocamlDownloadInstructions - " >&2;} - { (exit 1); exit 1; }; } -fi - -# -# ------------------- Perl ---------------- -# -echo "$as_me:$LINENO: checking for Perl" >&5 -echo $ECHO_N "checking for Perl... $ECHO_C" >&6 - if ! binaryExists perl; then - { { echo "$as_me:$LINENO: error: - perl not found. - You need perl version 5.6.1 or later for CIL. - You can get perl at http://www.cpan.org/src/index.html . - " >&5 -echo "$as_me: error: - perl not found. - You need perl version 5.6.1 or later for CIL. - You can get perl at http://www.cpan.org/src/index.html . - " >&2;} - { (exit 1); exit 1; }; } - fi - - # sm: oh how nice it would be to just say "use English; - # print($PERL_VERSION)", but that appears broken on 5.6.1.. so I'm - # trying to say "caret right-bracket", but then that would run afoul - # of autoconf's quoting characters, so I use the "quadrigraph" ] - # to stand for right-bracket. what a mess. - perlver=`perl -e 'print($]);'` - if perl -e "exit( $perlver >= 5.006001 );"; then - { { echo "$as_me:$LINENO: error: - Found perl version $perlver, but at least 5.6.1 is required. - You can get a newer perl at http://www.cpan.org/src/index.html . - " >&5 -echo "$as_me: error: - Found perl version $perlver, but at least 5.6.1 is required. - You can get a newer perl at http://www.cpan.org/src/index.html . - " >&2;} - { (exit 1); exit 1; }; } - fi - - perlport=`perl -e "print $^O;"` - case "$perlport" in - cygwin) - ;; - MSWin32) # ActivePerl - ;; - linux) - ;; - freebsd) - ;; - openbsd) - ;; - darwin) # Mac OS X - ;; - solaris) - ;; - *) - { { echo "$as_me:$LINENO: error: - Unsupported Perl port $perlport -- sorry. - cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin, - and solaris are the supported ports. - " >&5 -echo "$as_me: error: - Unsupported Perl port $perlport -- sorry. - cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin, - and solaris are the supported ports. - " >&2;} - { (exit 1); exit 1; }; } - esac -echo "$as_me:$LINENO: result: found version $perlver, port $perlport" >&5 -echo "${ECHO_T}found version $perlver, port $perlport" >&6 - - # The cygwin port has some bugs in the File::Spec module -if test "$perlport" = "cygwin" ;then - echo "$as_me:$LINENO: checking for known cygwin Perl bug in File::Spec" >&5 -echo $ECHO_N "checking for known cygwin Perl bug in File::Spec... $ECHO_C" >&6 - perlfixres=`perl -e ' - use File::Spec; - if(File::Spec->file_name_is_absolute("C:/test")) { - print "no bug found"; exit 0; - } else { - print "bug"; - foreach $d (@INC) { - if(-f "$d/File/Spec/Unix.pm") { - open(IN, "<$d/File/Spec/Unix.pm"); - open(OUT, ">$d/File/Spec/Unix.pm.fixed") - || die "Cannot open $d/File/Spec/Unix.pm.fixed"; - while() { - if($_ =~ m|sub file_name_is_absolute|) { - print OUT $_; - print OUT scalar(); - print OUT <file_name_is_absolute("C:/test")) { - print "bug fixed"; exit 0; - } else { - print "cannot fix bug"; exit 1; - }'` - fi - if test "x$perlfixres" = "x" ;then - { { echo "$as_me:$LINENO: error: - Cannot run perl - " >&5 -echo "$as_me: error: - Cannot run perl - " >&2;} - { (exit 1); exit 1; }; } - elif test "$perlfixres" = "cannot fix bug" ;then - { { echo "$as_me:$LINENO: error: - Found a bug but cannot fix it. - " >&5 -echo "$as_me: error: - Found a bug but cannot fix it. - " >&2;} - { (exit 1); exit 1; }; } - else - echo "$as_me:$LINENO: result: $perlfixres" >&5 -echo "${ECHO_T}$perlfixres" >&6 - fi -fi - -# -# Now setup the performance counters -# -echo "$as_me:$LINENO: checking if performance counters are usable" >&5 -echo $ECHO_N "checking if performance counters are usable... $ECHO_C" >&6 -# Create a C file from src/perfcount.c.in -rm -f ./cycles.exe -if gcc -DCONFIGURATION_ONLY \ - -x c ocamlutil/perfcount.c.in -lm -o ./cycles.exe >/dev/null 2>&1; then - - if CYCLES_PER_USEC=`./cycles.exe 2>&1` ;then - echo "$as_me:$LINENO: result: ok ($CYCLES_PER_USEC cycles per us)" >&5 -echo "${ECHO_T}ok ($CYCLES_PER_USEC cycles per us)" >&6 - else - # Print what we got - echo "$as_me:$LINENO: result: no ($CYCLES_PER_USEC)" >&5 -echo "${ECHO_T}no ($CYCLES_PER_USEC)" >&6 - CYCLES_PER_USEC=0 - fi -else - CYCLES_PER_USEC=0 - echo "$as_me:$LINENO: result: no (cannot compile perfcount.c)" >&5 -echo "${ECHO_T}no (cannot compile perfcount.c)" >&6 -fi -rm -f ./cycles.exe - -# If we are on Linux and we use performance counters try to get -# the processor speed from /proc/cpuinfo -if test "$CYCLES_PER_USEC" != "0" ;then - case "$target" in - # linux - *86*linux*) - echo "$as_me:$LINENO: checking if /proc/cpuinfo has processor speed" >&5 -echo $ECHO_N "checking if /proc/cpuinfo has processor speed... $ECHO_C" >&6 - cpuinfo=`cat /proc/cpuinfo 2>/dev/null | grep "cpu MHz"` - procspeed=`echo $cpuinfo | sed 's/^.*[^0-9]\([0-9]\+\.[0-9]\+\).*$/\1/g'` - if test "$procspeed"!="" ;then - CYCLES_PER_USEC=$procspeed - echo "$as_me:$LINENO: result: got $CYCLES_PER_USEC cycles per us" >&5 -echo "${ECHO_T}got $CYCLES_PER_USEC cycles per us" >&6 - else - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - fi - ;; - *) - ;; - esac - # Now set HAS_PERFCOUNT - HAS_PERFCOUNT=1 -else - HAS_PERFCOUNT=0 -fi - -# additional tools we might check for: -# - gnu make - -# -# -------------------- GCC -------------- -# - -echo "$as_me:$LINENO: checking for gcc version" >&5 -echo $ECHO_N "checking for gcc version... $ECHO_C" >&6 - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 -echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6 -# On Suns, sometimes $CPP names a directory. -if test -n "$CPP" && test -d "$CPP"; then - CPP= -fi -if test -z "$CPP"; then - if test "${ac_cv_prog_CPP+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - # Double quotes because CPP needs to be expanded - for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" - do - ac_preproc_ok=false -for ac_c_preproc_warn_flag in '' yes -do - # Use a header file that comes with gcc, so configuring glibc - # with a fresh cross-compiler works. - # Prefer to if __STDC__ is defined, since - # exists even on freestanding compilers. - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. "Syntax error" is here to catch this case. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#ifdef __STDC__ -# include -#else -# include -#endif - Syntax error -_ACEOF -if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 - (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null; then - if test -s conftest.err; then - ac_cpp_err=$ac_c_preproc_warn_flag - ac_cpp_err=$ac_cpp_err$ac_c_werror_flag - else - ac_cpp_err= - fi -else - ac_cpp_err=yes -fi -if test -z "$ac_cpp_err"; then - : -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.$ac_ext - - # OK, works on sane cases. Now check whether non-existent headers - # can be detected and how. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -_ACEOF -if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 - (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null; then - if test -s conftest.err; then - ac_cpp_err=$ac_c_preproc_warn_flag - ac_cpp_err=$ac_cpp_err$ac_c_werror_flag - else - ac_cpp_err= - fi -else - ac_cpp_err=yes -fi -if test -z "$ac_cpp_err"; then - # Broken: success on invalid input. -continue -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.err conftest.$ac_ext -if $ac_preproc_ok; then - break -fi - - done - ac_cv_prog_CPP=$CPP - -fi - CPP=$ac_cv_prog_CPP -else - ac_cv_prog_CPP=$CPP -fi -echo "$as_me:$LINENO: result: $CPP" >&5 -echo "${ECHO_T}$CPP" >&6 -ac_preproc_ok=false -for ac_c_preproc_warn_flag in '' yes -do - # Use a header file that comes with gcc, so configuring glibc - # with a fresh cross-compiler works. - # Prefer to if __STDC__ is defined, since - # exists even on freestanding compilers. - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. "Syntax error" is here to catch this case. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#ifdef __STDC__ -# include -#else -# include -#endif - Syntax error -_ACEOF -if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 - (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null; then - if test -s conftest.err; then - ac_cpp_err=$ac_c_preproc_warn_flag - ac_cpp_err=$ac_cpp_err$ac_c_werror_flag - else - ac_cpp_err= - fi -else - ac_cpp_err=yes -fi -if test -z "$ac_cpp_err"; then - : -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.$ac_ext - - # OK, works on sane cases. Now check whether non-existent headers - # can be detected and how. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -_ACEOF -if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 - (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null; then - if test -s conftest.err; then - ac_cpp_err=$ac_c_preproc_warn_flag - ac_cpp_err=$ac_cpp_err$ac_c_werror_flag - else - ac_cpp_err= - fi -else - ac_cpp_err=yes -fi -if test -z "$ac_cpp_err"; then - # Broken: success on invalid input. -continue -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.err conftest.$ac_ext -if $ac_preproc_ok; then - : -else - { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details." >&5 -echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -echo "$as_me:$LINENO: checking for egrep" >&5 -echo $ECHO_N "checking for egrep... $ECHO_C" >&6 -if test "${ac_cv_prog_egrep+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if echo a | (grep -E '(a|b)') >/dev/null 2>&1 - then ac_cv_prog_egrep='grep -E' - else ac_cv_prog_egrep='egrep' - fi -fi -echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5 -echo "${ECHO_T}$ac_cv_prog_egrep" >&6 - EGREP=$ac_cv_prog_egrep - - -echo "$as_me:$LINENO: checking for ANSI C header files" >&5 -echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 -if test "${ac_cv_header_stdc+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#include -#include -#include - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_header_stdc=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_header_stdc=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -if test $ac_cv_header_stdc = yes; then - # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then - : -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then - : -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then - : -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#if ((' ' & 0x0FF) == 0x020) -# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') -# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) -#else -# define ISLOWER(c) \ - (('a' <= (c) && (c) <= 'i') \ - || ('j' <= (c) && (c) <= 'r') \ - || ('s' <= (c) && (c) <= 'z')) -# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) -#endif - -#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) -int -main () -{ - int i; - for (i = 0; i < 256; i++) - if (XOR (islower (i), ISLOWER (i)) - || toupper (i) != TOUPPER (i)) - exit(2); - exit (0); -} -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - : -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -ac_cv_header_stdc=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -fi -fi -echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 -echo "${ECHO_T}$ac_cv_header_stdc" >&6 -if test $ac_cv_header_stdc = yes; then - -cat >>confdefs.h <<\_ACEOF -#define STDC_HEADERS 1 -_ACEOF - -fi - -# On IRIX 5.3, sys/types and inttypes.h are conflicting. - - - - - - - - - -for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ - inttypes.h stdint.h unistd.h -do -as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_header" >&5 -echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 -if eval "test \"\${$as_ac_Header+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default - -#include <$ac_header> -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_Header=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_Header=no" -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 -if test `eval echo '${'$as_ac_Header'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 -_ACEOF - -fi - -done - - -echo "$as_me:$LINENO: checking for __builtin_va_list" >&5 -echo $ECHO_N "checking for __builtin_va_list... $ECHO_C" >&6 -if test "${ac_cv_type___builtin_va_list+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ -if ((__builtin_va_list *) 0) - return 0; -if (sizeof (__builtin_va_list)) - return 0; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_type___builtin_va_list=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_type___builtin_va_list=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_type___builtin_va_list" >&5 -echo "${ECHO_T}$ac_cv_type___builtin_va_list" >&6 -if test $ac_cv_type___builtin_va_list = yes; then - HAVE_BUILTIN_VA_LIST=true -else - HAVE_BUILTIN_VA_LIST=false -fi - -echo "$as_me:$LINENO: checking if __thread is a keyword" >&5 -echo $ECHO_N "checking if __thread is a keyword... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF -int main(int __thread) { return 0; } -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - THREAD_IS_KEYWORD=false -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -THREAD_IS_KEYWORD=true -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -echo "$as_me:$LINENO: result: $THREAD_IS_KEYWORD" >&5 -echo "${ECHO_T}$THREAD_IS_KEYWORD" >&6 - -# Does gcc add underscores to identifiers to make assembly labels? -# (I think MSVC always does) -echo "$as_me:$LINENO: checking if gcc adds underscores to assembly labels." >&5 -echo $ECHO_N "checking if gcc adds underscores to assembly labels.... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF -int main() { __asm__("jmp _main"); } -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - UNDERSCORE_NAME=true -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -UNDERSCORE_NAME=false -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -echo "$as_me:$LINENO: result: $UNDERSCORE_NAME" >&5 -echo "${ECHO_T}$UNDERSCORE_NAME" >&6 - - -# ----------- some stuff 'autoscan' put here -------------- -# (autoscan is part of the autoconf distribution) - -# checks for header files -echo "$as_me:$LINENO: checking for ANSI C header files" >&5 -echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 -if test "${ac_cv_header_stdc+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#include -#include -#include - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_header_stdc=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_header_stdc=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - -if test $ac_cv_header_stdc = yes; then - # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then - : -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then - : -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then - : -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#if ((' ' & 0x0FF) == 0x020) -# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') -# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) -#else -# define ISLOWER(c) \ - (('a' <= (c) && (c) <= 'i') \ - || ('j' <= (c) && (c) <= 'r') \ - || ('s' <= (c) && (c) <= 'z')) -# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) -#endif - -#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) -int -main () -{ - int i; - for (i = 0; i < 256; i++) - if (XOR (islower (i), ISLOWER (i)) - || toupper (i) != TOUPPER (i)) - exit(2); - exit (0); -} -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - : -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -ac_cv_header_stdc=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -fi -fi -echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 -echo "${ECHO_T}$ac_cv_header_stdc" >&6 -if test $ac_cv_header_stdc = yes; then - -cat >>confdefs.h <<\_ACEOF -#define STDC_HEADERS 1 -_ACEOF - -fi - - - - - - -for ac_header in stdlib.h strings.h sys/time.h unistd.h wchar.h -do -as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` -if eval "test \"\${$as_ac_Header+set}\" = set"; then - echo "$as_me:$LINENO: checking for $ac_header" >&5 -echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 -if eval "test \"\${$as_ac_Header+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 -else - # Is the header compilable? -echo "$as_me:$LINENO: checking $ac_header usability" >&5 -echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include <$ac_header> -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_header_compiler=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_header_compiler=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -echo "${ECHO_T}$ac_header_compiler" >&6 - -# Is the header present? -echo "$as_me:$LINENO: checking $ac_header presence" >&5 -echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include <$ac_header> -_ACEOF -if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 - (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null; then - if test -s conftest.err; then - ac_cpp_err=$ac_c_preproc_warn_flag - ac_cpp_err=$ac_cpp_err$ac_c_werror_flag - else - ac_cpp_err= - fi -else - ac_cpp_err=yes -fi -if test -z "$ac_cpp_err"; then - ac_header_preproc=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi -rm -f conftest.err conftest.$ac_ext -echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -echo "${ECHO_T}$ac_header_preproc" >&6 - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 -echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 -echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 -echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 -echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 -echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} - ( - cat <<\_ASBOX -## ------------------------------------------ ## -## Report this to the AC_PACKAGE_NAME lists. ## -## ------------------------------------------ ## -_ASBOX - ) | - sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -echo "$as_me:$LINENO: checking for $ac_header" >&5 -echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 -if eval "test \"\${$as_ac_Header+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - eval "$as_ac_Header=\$ac_header_preproc" -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 - -fi -if test `eval echo '${'$as_ac_Header'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 -_ACEOF - -fi - -done - - -# checks for typedefs, structures, and compiler characteristics -echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5 -echo $ECHO_N "checking for an ANSI C-conforming const... $ECHO_C" >&6 -if test "${ac_cv_c_const+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ -/* FIXME: Include the comments suggested by Paul. */ -#ifndef __cplusplus - /* Ultrix mips cc rejects this. */ - typedef int charset[2]; - const charset x; - /* SunOS 4.1.1 cc rejects this. */ - char const *const *ccp; - char **p; - /* NEC SVR4.0.2 mips cc rejects this. */ - struct point {int x, y;}; - static struct point const zero = {0,0}; - /* AIX XL C 1.02.0.0 rejects this. - It does not let you subtract one const X* pointer from another in - an arm of an if-expression whose if-part is not a constant - expression */ - const char *g = "string"; - ccp = &g + (g ? g-g : 0); - /* HPUX 7.0 cc rejects these. */ - ++ccp; - p = (char**) ccp; - ccp = (char const *const *) p; - { /* SCO 3.2v4 cc rejects this. */ - char *t; - char const *s = 0 ? (char *) 0 : (char const *) 0; - - *t++ = 0; - } - { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ - int x[] = {25, 17}; - const int *foo = &x[0]; - ++foo; - } - { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ - typedef const int *iptr; - iptr p = 0; - ++p; - } - { /* AIX XL C 1.02.0.0 rejects this saying - "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ - struct s { int j; const int *ap[3]; }; - struct s *b; b->j = 5; - } - { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ - const int foo = 10; - } -#endif - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_c_const=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_c_const=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_c_const" >&5 -echo "${ECHO_T}$ac_cv_c_const" >&6 -if test $ac_cv_c_const = no; then - -cat >>confdefs.h <<\_ACEOF -#define const -_ACEOF - -fi - -echo "$as_me:$LINENO: checking for inline" >&5 -echo $ECHO_N "checking for inline... $ECHO_C" >&6 -if test "${ac_cv_c_inline+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - ac_cv_c_inline=no -for ac_kw in inline __inline__ __inline; do - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#ifndef __cplusplus -typedef int foo_t; -static $ac_kw foo_t static_foo () {return 0; } -$ac_kw foo_t foo () {return 0; } -#endif - -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_c_inline=$ac_kw; break -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -done - -fi -echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5 -echo "${ECHO_T}$ac_cv_c_inline" >&6 - - -case $ac_cv_c_inline in - inline | yes) ;; - *) - case $ac_cv_c_inline in - no) ac_val=;; - *) ac_val=$ac_cv_c_inline;; - esac - cat >>confdefs.h <<_ACEOF -#ifndef __cplusplus -#define inline $ac_val -#endif -_ACEOF - ;; -esac - -echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5 -echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 -if test "${ac_cv_header_time+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -#include -#include - -int -main () -{ -if ((struct tm *) 0) -return 0; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_header_time=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_header_time=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 -echo "${ECHO_T}$ac_cv_header_time" >&6 -if test $ac_cv_header_time = yes; then - -cat >>confdefs.h <<\_ACEOF -#define TIME_WITH_SYS_TIME 1 -_ACEOF - -fi - - -# checks for library functions; more autoscan stuff -echo "$as_me:$LINENO: checking for working memcmp" >&5 -echo $ECHO_N "checking for working memcmp... $ECHO_C" >&6 -if test "${ac_cv_func_memcmp_working+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test "$cross_compiling" = yes; then - ac_cv_func_memcmp_working=no -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ - - /* Some versions of memcmp are not 8-bit clean. */ - char c0 = 0x40, c1 = 0x80, c2 = 0x81; - if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0) - exit (1); - - /* The Next x86 OpenStep bug shows up only when comparing 16 bytes - or more and with at least one buffer not starting on a 4-byte boundary. - William Lewis provided this test program. */ - { - char foo[21]; - char bar[21]; - int i; - for (i = 0; i < 4; i++) - { - char *a = foo + i; - char *b = bar + i; - strcpy (a, "--------01111111"); - strcpy (b, "--------10000000"); - if (memcmp (a, b, 16) >= 0) - exit (1); - } - exit (0); - } - - ; - return 0; -} -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_func_memcmp_working=yes -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -ac_cv_func_memcmp_working=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -fi -echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5 -echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6 -test $ac_cv_func_memcmp_working = no && case $LIBOBJS in - "memcmp.$ac_objext" | \ - *" memcmp.$ac_objext" | \ - "memcmp.$ac_objext "* | \ - *" memcmp.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;; -esac - - - - - - -for ac_func in mkdir select socket __sysv_signal -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - - - -# ----------- platform-specific code ------------- -# $target is typically processor-vendor-os -case "$target" in - # linux - *86*linux*|*86*freebsd*|*86*openbsd*|*86*darwin*) - echo "$as_me:$LINENO: result: configuring for linux/x86" >&5 -echo "${ECHO_T}configuring for linux/x86" >&6 - - ARCHOS=x86_LINUX - ;; - - # Mac OS X - *powerpc*darwin*) - echo "$as_me:$LINENO: result: configuring for powerpc/darwin" >&5 -echo "${ECHO_T}configuring for powerpc/darwin" >&6 - - ARCHOS=ppc_DARWIN - ;; - - # cygwin - *86*cygwin*) - echo "$as_me:$LINENO: result: configuring for Cygwin on win32/x86" >&5 -echo "${ECHO_T}configuring for Cygwin on win32/x86" >&6 - - ARCHOS=x86_WIN32 - - # override CILHOME; even on cygwin we want forward slashes - # sm: I folded this into what I hope will be the only - # case-analysis of machine type - CILHOME=`cygpath -wa "$CILHOME" | sed -e "s/\\\\\/\\//g"` - CC=`which $CC` - CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"` - ;; - - # Solaris - *sparc*solaris*) - echo "$as_me:$LINENO: result: configuring for SPARC/Solaris" >&5 -echo "${ECHO_T}configuring for SPARC/Solaris" >&6 - - ARCHOS=sparc_SOLARIS - ;; - - *) - { { echo "$as_me:$LINENO: error: - Unsupported platform $target -- sorry. - ./configure supports these platforms: - on x86: Linux, Win32(with Cygwin), freeBSD, openBSD, and Mac OS X - on PowerPC: Mac OS X - on SPARC: Solaris - " >&5 -echo "$as_me: error: - Unsupported platform $target -- sorry. - ./configure supports these platforms: - on x86: Linux, Win32(with Cygwin), freeBSD, openBSD, and Mac OS X - on PowerPC: Mac OS X - on SPARC: Solaris - " >&2;} - { (exit 1); exit 1; }; } - ;; -esac - -# Make the object directory if not already present -as_ac_File=`echo "ac_cv_file_obj/$ARCHOS" | $as_tr_sh` -echo "$as_me:$LINENO: checking for obj/$ARCHOS" >&5 -echo $ECHO_N "checking for obj/$ARCHOS... $ECHO_C" >&6 -if eval "test \"\${$as_ac_File+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - test "$cross_compiling" = yes && - { { echo "$as_me:$LINENO: error: cannot check for file existence when cross compiling" >&5 -echo "$as_me: error: cannot check for file existence when cross compiling" >&2;} - { (exit 1); exit 1; }; } -if test -r "obj/$ARCHOS"; then - eval "$as_ac_File=yes" -else - eval "$as_ac_File=no" -fi -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_File'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_File'}'`" >&6 -if test `eval echo '${'$as_ac_File'}'` = yes; then - : -else - echo "$as_me:$LINENO: result: creating obj/$ARCHOS" >&5 -echo "${ECHO_T}creating obj/$ARCHOS" >&6; - mkdir -p obj/$ARCHOS -fi - - -echo "$as_me:$LINENO: checking delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file" >&5 -echo $ECHO_N "checking delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file... $ECHO_C" >&6 -rm -f obj/$ARCHOS/machdep.ml -rm -f obj/.depend/machdep.d -rm -f obj/$ARCHOS/feature_config.ml -rm -f obj/.depend/feature_config.d -echo "$as_me:$LINENO: result: done" >&5 -echo "${ECHO_T}done" >&6 - -# We will use substitution variables whose definition contains newlines. The -# problem is that when config.status runs, it wants to break the series of -# substitution commands for sed into fragments based on line count. We could -# be unlucky and have config.status break the series of substitution in the -# middle of a variable that contains newlines. So, we first create a single -# variable called NEWLINE whose definition is a carriage return. This means -# that there will be exactly one opportunity for this error to happen (in the -# definition of NEWLINE). The occurrence of AC_SUBST for NEWLINE must occur -# after those of the variables that use it! And we want to put all of these -# very early on, to make sure that they are not around the place when the file -# bets broken. - -NEWLINE="\\ -" - - -# -# CIL/CCured features -# -# - -# Set the defaults - - -# Give a space-separated list of features with the defaults -features="blockinggraph=no rand=no arithabs=no zrapp=no" - - -# Check whether --with-blockinggraph or --without-blockinggraph was given. -if test "${with_blockinggraph+set}" = set; then - withval="$with_blockinggraph" - -fi; - -# Check whether --with-rand or --without-rand was given. -if test "${with_rand+set}" = set; then - withval="$with_rand" - -fi; - -# Check whether --with-arithabs or --without-arithabs was given. -if test "${with_arithabs+set}" = set; then - withval="$with_arithabs" - -fi; - -# Check whether --with-zrapp or --without-zrapp was given. -if test "${with_zrapp+set}" = set; then - withval="$with_zrapp" - -fi; - -# Smalloc.ml is distributed by {matth,nks}@cs.berkeley.edu as part of Scrash. -features="$features smalloc=no" - -# cqualann.ml is used by Matt Harren. Please ignore. -features="$features cqualann=no" - -# Now add any features specified in the command-line - -features="$features $EXTRAFEATURES" - -for f_val in $features -do - # If there is no =, then we default to yes - if ! (echo $f_val | grep "=" >/dev/null) ;then f_val="$f_val=yes"; fi - # echo "Testing feature $f_val" - f=`echo $f_val | sed -e s%=.*$%%` - echo "$as_me:$LINENO: checking whether to use CIL feature $f" >&5 -echo $ECHO_N "checking whether to use CIL feature $f... $ECHO_C" >&6 - # default value from "features" - defval=`echo $f_val | sed -e s%^.*=%%` - # current value - getcurval="echo \${with_$f:=$defval}" - curval=`eval $getcurval` - echo "$as_me:$LINENO: result: $curval" >&5 -echo "${ECHO_T}$curval" >&6 - if test $curval = yes ;then - CIL_FEATURES="$CIL_FEATURES $f" - fi -done - -## Now produce the CIL_FEATURES_DEFINES -CIL_FEATURES_DEFINES="" -# Convert to upper case -for f in `echo $CIL_FEATURES | tr a-z A-Z` -do - CIL_FEATURES_DEFINES="${CIL_FEATURES_DEFINES}@NEWLINE@export USE_$f=yes" -done - - -# ----------------- finish up ------------------- -# names of the variables that get substituted in files; for example, -# write @ARCHOS@ somewhere in a written file to get it substituted - - - - - - - - - - - - - - - - - -# finish the configure script and generate various files; ./configure -# will apply variable substitutions to .in to generate ; -# I find it useful to mark generated files as read-only so I don't -# accidentally edit them (and them lose my changes when ./configure -# runs again); I had originally done the chmod after AC_OUTPUT, but -# the problem is then the chmod doesn't run inside ./config.status - -# MY_AC_CONFIG_FILES(filename) -# do AC_CONFIG_FILES(filename, chmod a-w filename) - - - -{ - if test -f Makefile.in; then - ac_config_files="$ac_config_files Makefile" - - else - true - #echo "skipping [Makefile] because it's not in this distribution" - fi -} -{ - if test -f cil.spec.in; then - ac_config_files="$ac_config_files cil.spec" - - else - true - #echo "skipping [cil.spec] because it's not in this distribution" - fi -} -{ - if test -f config.mk.in; then - ac_config_files="$ac_config_files config.mk" - - else - true - #echo "skipping [config.mk] because it's not in this distribution" - fi -} -{ - if test -f test/Makefile.in; then - ac_config_files="$ac_config_files test/Makefile" - - else - true - #echo "skipping [test/Makefile] because it's not in this distribution" - fi -} -{ - if test -f bin/cilly.bat.in; then - ac_config_files="$ac_config_files bin/cilly.bat" - - else - true - #echo "skipping [bin/cilly.bat] because it's not in this distribution" - fi -} -{ - if test -f bin/patcher.bat.in; then - ac_config_files="$ac_config_files bin/patcher.bat" - - else - true - #echo "skipping [bin/patcher.bat] because it's not in this distribution" - fi -} -{ - if test -f bin/CilConfig.pm.in; then - ac_config_files="$ac_config_files bin/CilConfig.pm" - - else - true - #echo "skipping [bin/CilConfig.pm] because it's not in this distribution" - fi -} -{ - if test -f doc/index.html.in; then - ac_config_files="$ac_config_files doc/index.html" - - else - true - #echo "skipping [doc/index.html] because it's not in this distribution" - fi -} -{ - if test -f doc/header.html.in; then - ac_config_files="$ac_config_files doc/header.html" - - else - true - #echo "skipping [doc/header.html] because it's not in this distribution" - fi -} -{ - if test -f ocamlutil/perfcount.c.in; then - ac_config_files="$ac_config_files ocamlutil/perfcount.c" - - else - true - #echo "skipping [ocamlutil/perfcount.c] because it's not in this distribution" - fi -} - -cat >confcache <<\_ACEOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs, see configure's option --config-cache. -# It is not useful on other systems. If it contains results you don't -# want to keep, you may remove or edit it. -# -# config.status only pays attention to the cache file if you give it -# the --recheck option to rerun configure. -# -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the -# following values. - -_ACEOF - -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -{ - (set) 2>&1 | - case `(ac_space=' '; set | grep ac_space) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n \ - "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" - ;; - esac; -} | - sed ' - t clear - : clear - s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ - t end - /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - : end' >>confcache -if diff $cache_file confcache >/dev/null 2>&1; then :; else - if test -w $cache_file; then - test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" - cat confcache >$cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# VPATH may cause trouble with some makes, so we remove $(srcdir), -# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=/{ -s/:*\$(srcdir):*/:/; -s/:*\${srcdir}:*/:/; -s/:*@srcdir@:*/:/; -s/^\([^=]*=[ ]*\):*/\1/; -s/:*$//; -s/^[^=]*=[ ]*$//; -}' -fi - -DEFS=-DHAVE_CONFIG_H - -ac_libobjs= -ac_ltlibobjs= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_i=`echo "$ac_i" | - sed 's/\$U\././;s/\.o$//;s/\.obj$//'` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext" - ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - - - -: ${CONFIG_STATUS=./config.status} -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 -echo "$as_me: creating $CONFIG_STATUS" >&6;} -cat >$CONFIG_STATUS <<_ACEOF -#! $SHELL -# Generated by $as_me. -# Run this file to recreate the current configuration. -# Compiler output produced by configure, useful for debugging -# configure, is in config.log if it exists. - -debug=false -ac_cs_recheck=false -ac_cs_silent=false -SHELL=\${CONFIG_SHELL-$SHELL} -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF -## --------------------- ## -## M4sh Initialization. ## -## --------------------- ## - -# Be Bourne compatible -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then - emulate sh - NULLCMD=: - # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' -elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then - set -o posix -fi -DUALCASE=1; export DUALCASE # for MKS sh - -# Support unset when possible. -if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then - as_unset=unset -else - as_unset=false -fi - - -# Work around bugs in pre-3.0 UWIN ksh. -$as_unset ENV MAIL MAILPATH -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -for as_var in \ - LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ - LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ - LC_TELEPHONE LC_TIME -do - if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then - eval $as_var=C; export $as_var - else - $as_unset $as_var - fi -done - -# Required to use basename. -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - - -# Name of the executable. -as_me=`$as_basename "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)$' \| \ - . : '\(.\)' 2>/dev/null || -echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } - /^X\/\(\/\/\)$/{ s//\1/; q; } - /^X\/\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - - -# PATH needs CR, and LINENO needs CR and PATH. -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - echo "#! /bin/sh" >conf$$.sh - echo "exit 0" >>conf$$.sh - chmod +x conf$$.sh - if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then - PATH_SEPARATOR=';' - else - PATH_SEPARATOR=: - fi - rm -f conf$$.sh -fi - - - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" || { - # Find who we are. Look in the path if we contain no path at all - # relative or not. - case $0 in - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break -done - - ;; - esac - # We did not find ourselves, most probably we were run as `sh COMMAND' - # in which case we are not to be found in the path. - if test "x$as_myself" = x; then - as_myself=$0 - fi - if test ! -f "$as_myself"; then - { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 -echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} - { (exit 1); exit 1; }; } - fi - case $CONFIG_SHELL in - '') - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for as_base in sh bash ksh sh5; do - case $as_dir in - /*) - if ("$as_dir/$as_base" -c ' - as_lineno_1=$LINENO - as_lineno_2=$LINENO - as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then - $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } - $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } - CONFIG_SHELL=$as_dir/$as_base - export CONFIG_SHELL - exec "$CONFIG_SHELL" "$0" ${1+"$@"} - fi;; - esac - done -done -;; - esac - - # Create $as_me.lineno as a copy of $as_myself, but with $LINENO - # uniformly replaced by the line number. The first 'sed' inserts a - # line-number line before each line; the second 'sed' does the real - # work. The second script uses 'N' to pair each line-number line - # with the numbered line, and appends trailing '-' during - # substitution so that $LINENO is not a special case at line end. - # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the - # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) - sed '=' <$as_myself | - sed ' - N - s,$,-, - : loop - s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, - t loop - s,-$,, - s,^['$as_cr_digits']*\n,, - ' >$as_me.lineno && - chmod +x $as_me.lineno || - { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 -echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} - { (exit 1); exit 1; }; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensible to this). - . ./$as_me.lineno - # Exit status is that of the last command. - exit -} - - -case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in - *c*,-n*) ECHO_N= ECHO_C=' -' ECHO_T=' ' ;; - *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; - *) ECHO_N= ECHO_C='\c' ECHO_T= ;; -esac - -if expr a : '\(a\)' >/dev/null 2>&1; then - as_expr=expr -else - as_expr=false -fi - -rm -f conf$$ conf$$.exe conf$$.file -echo >conf$$.file -if ln -s conf$$.file conf$$ 2>/dev/null; then - # We could just check for DJGPP; but this test a) works b) is more generic - # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). - if test -f conf$$.exe; then - # Don't use ln at all; we don't have any links - as_ln_s='cp -p' - else - as_ln_s='ln -s' - fi -elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.file - -if mkdir -p . 2>/dev/null; then - as_mkdir_p=: -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_executable_p="test -f" - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -# IFS -# We need space, tab and new line, in precisely that order. -as_nl=' -' -IFS=" $as_nl" - -# CDPATH. -$as_unset CDPATH - -exec 6>&1 - -# Open the log real soon, to keep \$[0] and so on meaningful, and to -# report actual input values of CONFIG_FILES etc. instead of their -# values after options handling. Logging --version etc. is OK. -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX -} >&5 -cat >&5 <<_CSEOF - -This file was extended by $as_me, which was -generated by GNU Autoconf 2.59. Invocation command line was - - CONFIG_FILES = $CONFIG_FILES - CONFIG_HEADERS = $CONFIG_HEADERS - CONFIG_LINKS = $CONFIG_LINKS - CONFIG_COMMANDS = $CONFIG_COMMANDS - $ $0 $@ - -_CSEOF -echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 -echo >&5 -_ACEOF - -# Files that config.status was made for. -if test -n "$ac_config_files"; then - echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS -fi - -if test -n "$ac_config_headers"; then - echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS -fi - -if test -n "$ac_config_links"; then - echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS -fi - -if test -n "$ac_config_commands"; then - echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS -fi - -cat >>$CONFIG_STATUS <<\_ACEOF - -ac_cs_usage="\ -\`$as_me' instantiates files from templates according to the -current configuration. - -Usage: $0 [OPTIONS] [FILE]... - - -h, --help print this help, then exit - -V, --version print version number, then exit - -q, --quiet do not print progress messages - -d, --debug don't remove temporary files - --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE - --header=FILE[:TEMPLATE] - instantiate the configuration header FILE - -Configuration files: -$config_files - -Configuration headers: -$config_headers - -Report bugs to ." -_ACEOF - -cat >>$CONFIG_STATUS <<_ACEOF -ac_cs_version="\\ -config.status -configured by $0, generated by GNU Autoconf 2.59, - with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" - -Copyright (C) 2003 Free Software Foundation, Inc. -This config.status script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it." -srcdir=$srcdir -INSTALL="$INSTALL" -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF -# If no file are specified by the user, then we need to provide default -# value. By we need to know if files were specified by the user. -ac_need_defaults=: -while test $# != 0 -do - case $1 in - --*=*) - ac_option=`expr "x$1" : 'x\([^=]*\)='` - ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` - ac_shift=: - ;; - -*) - ac_option=$1 - ac_optarg=$2 - ac_shift=shift - ;; - *) # This is not an option, so the user has probably given explicit - # arguments. - ac_option=$1 - ac_need_defaults=false;; - esac - - case $ac_option in - # Handling of the options. -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - ac_cs_recheck=: ;; - --version | --vers* | -V ) - echo "$ac_cs_version"; exit 0 ;; - --he | --h) - # Conflict between --help and --header - { { echo "$as_me:$LINENO: error: ambiguous option: $1 -Try \`$0 --help' for more information." >&5 -echo "$as_me: error: ambiguous option: $1 -Try \`$0 --help' for more information." >&2;} - { (exit 1); exit 1; }; };; - --help | --hel | -h ) - echo "$ac_cs_usage"; exit 0 ;; - --debug | --d* | -d ) - debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - CONFIG_FILES="$CONFIG_FILES $ac_optarg" - ac_need_defaults=false;; - --header | --heade | --head | --hea ) - $ac_shift - CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" - ac_need_defaults=false;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil | --si | --s) - ac_cs_silent=: ;; - - # This is an error. - -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 -Try \`$0 --help' for more information." >&5 -echo "$as_me: error: unrecognized option: $1 -Try \`$0 --help' for more information." >&2;} - { (exit 1); exit 1; }; } ;; - - *) ac_config_targets="$ac_config_targets $1" ;; - - esac - shift -done - -ac_configure_extra_args= - -if $ac_cs_silent; then - exec 6>/dev/null - ac_configure_extra_args="$ac_configure_extra_args --silent" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF -if \$ac_cs_recheck; then - echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 - exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion -fi - -_ACEOF - - - - - -cat >>$CONFIG_STATUS <<\_ACEOF -for ac_config_target in $ac_config_targets -do - case "$ac_config_target" in - # Handling of arguments. - "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; - "cil.spec" ) CONFIG_FILES="$CONFIG_FILES cil.spec" ;; - "config.mk" ) CONFIG_FILES="$CONFIG_FILES config.mk" ;; - "test/Makefile" ) CONFIG_FILES="$CONFIG_FILES test/Makefile" ;; - "bin/cilly.bat" ) CONFIG_FILES="$CONFIG_FILES bin/cilly.bat" ;; - "bin/patcher.bat" ) CONFIG_FILES="$CONFIG_FILES bin/patcher.bat" ;; - "bin/CilConfig.pm" ) CONFIG_FILES="$CONFIG_FILES bin/CilConfig.pm" ;; - "doc/index.html" ) CONFIG_FILES="$CONFIG_FILES doc/index.html" ;; - "doc/header.html" ) CONFIG_FILES="$CONFIG_FILES doc/header.html" ;; - "ocamlutil/perfcount.c" ) CONFIG_FILES="$CONFIG_FILES ocamlutil/perfcount.c" ;; - "config.h" ) CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; - *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 -echo "$as_me: error: invalid argument: $ac_config_target" >&2;} - { (exit 1); exit 1; }; };; - esac -done - -# If the user did not use the arguments to specify the items to instantiate, -# then the envvar interface is used. Set only those that are not. -# We use the long form for the default assignment because of an extremely -# bizarre bug on SunOS 4.1.3. -if $ac_need_defaults; then - test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files - test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers -fi - -# Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason to put it here, and in addition, -# creating and moving files from /tmp can sometimes cause problems. -# Create a temporary directory, and hook for its removal unless debugging. -$debug || -{ - trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 - trap '{ (exit 1); exit 1; }' 1 2 13 15 -} - -# Create a (secure) tmp directory for tmp files. - -{ - tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && - test -n "$tmp" && test -d "$tmp" -} || -{ - tmp=./confstat$$-$RANDOM - (umask 077 && mkdir $tmp) -} || -{ - echo "$me: cannot create a temporary directory in ." >&2 - { (exit 1); exit 1; } -} - -_ACEOF - -cat >>$CONFIG_STATUS <<_ACEOF - -# -# CONFIG_FILES section. -# - -# No need to generate the scripts if there are no CONFIG_FILES. -# This happens for instance when ./config.status config.h -if test -n "\$CONFIG_FILES"; then - # Protect against being on the right side of a sed subst in config.status. - sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; - s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF -s,@CIL_FEATURES_DEFINES@,$CIL_FEATURES_DEFINES,;t t -s,@NEWLINE@,$NEWLINE,;t t -s,@SHELL@,$SHELL,;t t -s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t -s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t -s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t -s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t -s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t -s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t -s,@exec_prefix@,$exec_prefix,;t t -s,@prefix@,$prefix,;t t -s,@program_transform_name@,$program_transform_name,;t t -s,@bindir@,$bindir,;t t -s,@sbindir@,$sbindir,;t t -s,@libexecdir@,$libexecdir,;t t -s,@datadir@,$datadir,;t t -s,@sysconfdir@,$sysconfdir,;t t -s,@sharedstatedir@,$sharedstatedir,;t t -s,@localstatedir@,$localstatedir,;t t -s,@libdir@,$libdir,;t t -s,@includedir@,$includedir,;t t -s,@oldincludedir@,$oldincludedir,;t t -s,@infodir@,$infodir,;t t -s,@mandir@,$mandir,;t t -s,@build_alias@,$build_alias,;t t -s,@host_alias@,$host_alias,;t t -s,@target_alias@,$target_alias,;t t -s,@DEFS@,$DEFS,;t t -s,@ECHO_C@,$ECHO_C,;t t -s,@ECHO_N@,$ECHO_N,;t t -s,@ECHO_T@,$ECHO_T,;t t -s,@LIBS@,$LIBS,;t t -s,@CC@,$CC,;t t -s,@CFLAGS@,$CFLAGS,;t t -s,@LDFLAGS@,$LDFLAGS,;t t -s,@CPPFLAGS@,$CPPFLAGS,;t t -s,@ac_ct_CC@,$ac_ct_CC,;t t -s,@EXEEXT@,$EXEEXT,;t t -s,@OBJEXT@,$OBJEXT,;t t -s,@INSTALL_PROGRAM@,$INSTALL_PROGRAM,;t t -s,@INSTALL_SCRIPT@,$INSTALL_SCRIPT,;t t -s,@INSTALL_DATA@,$INSTALL_DATA,;t t -s,@build@,$build,;t t -s,@build_cpu@,$build_cpu,;t t -s,@build_vendor@,$build_vendor,;t t -s,@build_os@,$build_os,;t t -s,@host@,$host,;t t -s,@host_cpu@,$host_cpu,;t t -s,@host_vendor@,$host_vendor,;t t -s,@host_os@,$host_os,;t t -s,@target@,$target,;t t -s,@target_cpu@,$target_cpu,;t t -s,@target_vendor@,$target_vendor,;t t -s,@target_os@,$target_os,;t t -s,@CPP@,$CPP,;t t -s,@EGREP@,$EGREP,;t t -s,@LIBOBJS@,$LIBOBJS,;t t -s,@ARCHOS@,$ARCHOS,;t t -s,@CILHOME@,$CILHOME,;t t -s,@HAS_MSVC@,$HAS_MSVC,;t t -s,@DEFAULT_COMPILER@,$DEFAULT_COMPILER,;t t -s,@DEFAULT_CIL_MODE@,$DEFAULT_CIL_MODE,;t t -s,@CIL_VERSION_MAJOR@,$CIL_VERSION_MAJOR,;t t -s,@CIL_VERSION_MINOR@,$CIL_VERSION_MINOR,;t t -s,@CIL_VERSION_REV@,$CIL_VERSION_REV,;t t -s,@CIL_VERSION@,$CIL_VERSION,;t t -s,@CYCLES_PER_USEC@,$CYCLES_PER_USEC,;t t -s,@HAS_PERFCOUNT@,$HAS_PERFCOUNT,;t t -s,@HAVE_BUILTIN_VA_LIST@,$HAVE_BUILTIN_VA_LIST,;t t -s,@THREAD_IS_KEYWORD@,$THREAD_IS_KEYWORD,;t t -s,@UNDERSCORE_NAME@,$UNDERSCORE_NAME,;t t -s,@EXTRAFEATURES@,$EXTRAFEATURES,;t t -s,@EXTRASRCDIRS@,$EXTRASRCDIRS,;t t -s,@LTLIBOBJS@,$LTLIBOBJS,;t t -CEOF - -_ACEOF - - cat >>$CONFIG_STATUS <<\_ACEOF - # Split the substitutions into bite-sized pieces for seds with - # small command number limits, like on Digital OSF/1 and HP-UX. - ac_max_sed_lines=48 - ac_sed_frag=1 # Number of current file. - ac_beg=1 # First line for current file. - ac_end=$ac_max_sed_lines # Line after last line for current file. - ac_more_lines=: - ac_sed_cmds= - while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag - else - sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag - fi - if test ! -s $tmp/subs.frag; then - ac_more_lines=false - else - # The purpose of the label and of the branching condition is to - # speed up the sed processing (if there are no `@' at all, there - # is no need to browse any of the substitutions). - # These are the two extra sed commands mentioned above. - (echo ':t - /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" - else - ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" - fi - ac_sed_frag=`expr $ac_sed_frag + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_lines` - fi - done - if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat - fi -fi # test -n "$CONFIG_FILES" - -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF -for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case $ac_file in - - | *:- | *:-:* ) # input from stdin - cat >$tmp/stdin - ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; - *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; - * ) ac_file_in=$ac_file.in ;; - esac - - # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. - ac_dir=`(dirname "$ac_file") 2>/dev/null || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - { if $as_mkdir_p; then - mkdir -p "$ac_dir" - else - as_dir="$ac_dir" - as_dirs= - while test ! -d "$as_dir"; do - as_dirs="$as_dir $as_dirs" - as_dir=`(dirname "$as_dir") 2>/dev/null || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - done - test ! -n "$as_dirs" || mkdir $as_dirs - fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 -echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} - { (exit 1); exit 1; }; }; } - - ac_builddir=. - -if test "$ac_dir" != .; then - ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` - # A "../" for each directory in $ac_dir_suffix. - ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` -else - ac_dir_suffix= ac_top_builddir= -fi - -case $srcdir in - .) # No --srcdir option. We are building in place. - ac_srcdir=. - if test -z "$ac_top_builddir"; then - ac_top_srcdir=. - else - ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` - fi ;; - [\\/]* | ?:[\\/]* ) # Absolute path. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir ;; - *) # Relative path. - ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_builddir$srcdir ;; -esac - -# Do not use `cd foo && pwd` to compute absolute paths, because -# the directories may not exist. -case `pwd` in -.) ac_abs_builddir="$ac_dir";; -*) - case "$ac_dir" in - .) ac_abs_builddir=`pwd`;; - [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; - *) ac_abs_builddir=`pwd`/"$ac_dir";; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_builddir=${ac_top_builddir}.;; -*) - case ${ac_top_builddir}. in - .) ac_abs_top_builddir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; - *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_srcdir=$ac_srcdir;; -*) - case $ac_srcdir in - .) ac_abs_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; - *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; - esac;; -esac -case $ac_abs_builddir in -.) ac_abs_top_srcdir=$ac_top_srcdir;; -*) - case $ac_top_srcdir in - .) ac_abs_top_srcdir=$ac_abs_builddir;; - [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; - *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; - esac;; -esac - - - case $INSTALL in - [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; - *) ac_INSTALL=$ac_top_builddir$INSTALL ;; - esac - - if test x"$ac_file" != x-; then - { echo "$as_me:$LINENO: creating $ac_file" >&5 -echo "$as_me: creating $ac_file" >&6;} - rm -f "$ac_file" - fi - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - if test x"$ac_file" = x-; then - configure_input= - else - configure_input="$ac_file. " - fi - configure_input=$configure_input"Generated from `echo $ac_file_in | - sed 's,.*/,,'` by configure." - - # First look for the input files in the build tree, otherwise in the - # src tree. - ac_file_inputs=`IFS=: - for f in $ac_file_in; do - case $f in - -) echo $tmp/stdin ;; - [\\/$]*) - # Absolute (can't be DOS-style, as IFS=:) - test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - echo "$f";; - *) # Relative - if test -f "$f"; then - # Build tree - echo "$f" - elif test -f "$srcdir/$f"; then - # Source tree - echo "$srcdir/$f" - else - # /dev/null tree - { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - fi;; - esac - done` || { (exit 1); exit 1; } -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF - sed "$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s,@configure_input@,$configure_input,;t t -s,@srcdir@,$ac_srcdir,;t t -s,@abs_srcdir@,$ac_abs_srcdir,;t t -s,@top_srcdir@,$ac_top_srcdir,;t t -s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t -s,@builddir@,$ac_builddir,;t t -s,@abs_builddir@,$ac_abs_builddir,;t t -s,@top_builddir@,$ac_top_builddir,;t t -s,@abs_top_builddir@,$ac_abs_top_builddir,;t t -s,@INSTALL@,$ac_INSTALL,;t t -" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out - rm -f $tmp/stdin - if test x"$ac_file" != x-; then - mv $tmp/out $ac_file - else - cat $tmp/out - rm -f $tmp/out - fi - - # Run the commands associated with the file. - case $ac_file in - Makefile ) chmod a-w Makefile ;; - cil.spec ) chmod a-w cil.spec ;; - config.mk ) chmod a-w config.mk ;; - test/Makefile ) chmod a-w test/Makefile ;; - bin/cilly.bat ) chmod a-w,a+x bin/cilly.bat ;; - bin/patcher.bat ) chmod a-w,a+x bin/patcher.bat ;; - bin/CilConfig.pm ) chmod a-w bin/CilConfig.pm ;; - doc/index.html ) chmod a-w doc/index.html ;; - doc/header.html ) chmod a-w doc/header.html ;; - ocamlutil/perfcount.c ) chmod a-w ocamlutil/perfcount.c ;; - esac -done -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF - -# -# CONFIG_HEADER section. -# - -# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where -# NAME is the cpp macro being defined and VALUE is the value it is being given. -# -# ac_d sets the value in "#define NAME VALUE" lines. -ac_dA='s,^\([ ]*\)#\([ ]*define[ ][ ]*\)' -ac_dB='[ ].*$,\1#\2' -ac_dC=' ' -ac_dD=',;t' -# ac_u turns "#undef NAME" without trailing blanks into "#define NAME VALUE". -ac_uA='s,^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' -ac_uB='$,\1#\2define\3' -ac_uC=' ' -ac_uD=',;t' - -for ac_file in : $CONFIG_HEADERS; do test "x$ac_file" = x: && continue - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case $ac_file in - - | *:- | *:-:* ) # input from stdin - cat >$tmp/stdin - ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; - *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` - ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; - * ) ac_file_in=$ac_file.in ;; - esac - - test x"$ac_file" != x- && { echo "$as_me:$LINENO: creating $ac_file" >&5 -echo "$as_me: creating $ac_file" >&6;} - - # First look for the input files in the build tree, otherwise in the - # src tree. - ac_file_inputs=`IFS=: - for f in $ac_file_in; do - case $f in - -) echo $tmp/stdin ;; - [\\/$]*) - # Absolute (can't be DOS-style, as IFS=:) - test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - # Do quote $f, to prevent DOS paths from being IFS'd. - echo "$f";; - *) # Relative - if test -f "$f"; then - # Build tree - echo "$f" - elif test -f "$srcdir/$f"; then - # Source tree - echo "$srcdir/$f" - else - # /dev/null tree - { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 -echo "$as_me: error: cannot find input file: $f" >&2;} - { (exit 1); exit 1; }; } - fi;; - esac - done` || { (exit 1); exit 1; } - # Remove the trailing spaces. - sed 's/[ ]*$//' $ac_file_inputs >$tmp/in - -_ACEOF - -# Transform confdefs.h into two sed scripts, `conftest.defines' and -# `conftest.undefs', that substitutes the proper values into -# config.h.in to produce config.h. The first handles `#define' -# templates, and the second `#undef' templates. -# And first: Protect against being on the right side of a sed subst in -# config.status. Protect against being in an unquoted here document -# in config.status. -rm -f conftest.defines conftest.undefs -# Using a here document instead of a string reduces the quoting nightmare. -# Putting comments in sed scripts is not portable. -# -# `end' is used to avoid that the second main sed command (meant for -# 0-ary CPP macros) applies to n-ary macro definitions. -# See the Autoconf documentation for `clear'. -cat >confdef2sed.sed <<\_ACEOF -s/[\\&,]/\\&/g -s,[\\$`],\\&,g -t clear -: clear -s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*\)\(([^)]*)\)[ ]*\(.*\)$,${ac_dA}\1${ac_dB}\1\2${ac_dC}\3${ac_dD},gp -t end -s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)$,${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD},gp -: end -_ACEOF -# If some macros were called several times there might be several times -# the same #defines, which is useless. Nevertheless, we may not want to -# sort them, since we want the *last* AC-DEFINE to be honored. -uniq confdefs.h | sed -n -f confdef2sed.sed >conftest.defines -sed 's/ac_d/ac_u/g' conftest.defines >conftest.undefs -rm -f confdef2sed.sed - -# This sed command replaces #undef with comments. This is necessary, for -# example, in the case of _POSIX_SOURCE, which is predefined and required -# on some systems where configure will not decide to define it. -cat >>conftest.undefs <<\_ACEOF -s,^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*,/* & */, -_ACEOF - -# Break up conftest.defines because some shells have a limit on the size -# of here documents, and old seds have small limits too (100 cmds). -echo ' # Handle all the #define templates only if necessary.' >>$CONFIG_STATUS -echo ' if grep "^[ ]*#[ ]*define" $tmp/in >/dev/null; then' >>$CONFIG_STATUS -echo ' # If there are no defines, we may have an empty if/fi' >>$CONFIG_STATUS -echo ' :' >>$CONFIG_STATUS -rm -f conftest.tail -while grep . conftest.defines >/dev/null -do - # Write a limited-size here document to $tmp/defines.sed. - echo ' cat >$tmp/defines.sed <>$CONFIG_STATUS - # Speed up: don't consider the non `#define' lines. - echo '/^[ ]*#[ ]*define/!b' >>$CONFIG_STATUS - # Work around the forget-to-reset-the-flag bug. - echo 't clr' >>$CONFIG_STATUS - echo ': clr' >>$CONFIG_STATUS - sed ${ac_max_here_lines}q conftest.defines >>$CONFIG_STATUS - echo 'CEOF - sed -f $tmp/defines.sed $tmp/in >$tmp/out - rm -f $tmp/in - mv $tmp/out $tmp/in -' >>$CONFIG_STATUS - sed 1,${ac_max_here_lines}d conftest.defines >conftest.tail - rm -f conftest.defines - mv conftest.tail conftest.defines -done -rm -f conftest.defines -echo ' fi # grep' >>$CONFIG_STATUS -echo >>$CONFIG_STATUS - -# Break up conftest.undefs because some shells have a limit on the size -# of here documents, and old seds have small limits too (100 cmds). -echo ' # Handle all the #undef templates' >>$CONFIG_STATUS -rm -f conftest.tail -while grep . conftest.undefs >/dev/null -do - # Write a limited-size here document to $tmp/undefs.sed. - echo ' cat >$tmp/undefs.sed <>$CONFIG_STATUS - # Speed up: don't consider the non `#undef' - echo '/^[ ]*#[ ]*undef/!b' >>$CONFIG_STATUS - # Work around the forget-to-reset-the-flag bug. - echo 't clr' >>$CONFIG_STATUS - echo ': clr' >>$CONFIG_STATUS - sed ${ac_max_here_lines}q conftest.undefs >>$CONFIG_STATUS - echo 'CEOF - sed -f $tmp/undefs.sed $tmp/in >$tmp/out - rm -f $tmp/in - mv $tmp/out $tmp/in -' >>$CONFIG_STATUS - sed 1,${ac_max_here_lines}d conftest.undefs >conftest.tail - rm -f conftest.undefs - mv conftest.tail conftest.undefs -done -rm -f conftest.undefs - -cat >>$CONFIG_STATUS <<\_ACEOF - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - if test x"$ac_file" = x-; then - echo "/* Generated by configure. */" >$tmp/config.h - else - echo "/* $ac_file. Generated by configure. */" >$tmp/config.h - fi - cat $tmp/in >>$tmp/config.h - rm -f $tmp/in - if test x"$ac_file" != x-; then - if diff $ac_file $tmp/config.h >/dev/null 2>&1; then - { echo "$as_me:$LINENO: $ac_file is unchanged" >&5 -echo "$as_me: $ac_file is unchanged" >&6;} - else - ac_dir=`(dirname "$ac_file") 2>/dev/null || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - { if $as_mkdir_p; then - mkdir -p "$ac_dir" - else - as_dir="$ac_dir" - as_dirs= - while test ! -d "$as_dir"; do - as_dirs="$as_dir $as_dirs" - as_dir=`(dirname "$as_dir") 2>/dev/null || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| \ - . : '\(.\)' 2>/dev/null || -echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } - /^X\(\/\/\)[^/].*/{ s//\1/; q; } - /^X\(\/\/\)$/{ s//\1/; q; } - /^X\(\/\).*/{ s//\1/; q; } - s/.*/./; q'` - done - test ! -n "$as_dirs" || mkdir $as_dirs - fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 -echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} - { (exit 1); exit 1; }; }; } - - rm -f $ac_file - mv $tmp/config.h $ac_file - fi - else - cat $tmp/config.h - rm -f $tmp/config.h - fi -done -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF - -{ (exit 0); exit 0; } -_ACEOF -chmod +x $CONFIG_STATUS -ac_clean_files=$ac_clean_files_save - - -# configure is writing to config.log, and then calls config.status. -# config.status does its own redirection, appending to config.log. -# Unfortunately, on DOS this fails, as config.log is still kept open -# by configure, so config.status won't be able to write to it; its -# output is simply discarded. So we exec the FD to /dev/null, -# effectively closing config.log, so it can be properly (re)opened and -# appended to by config.status. When coming back to configure, we -# need to make the FD available again. -if test "$no_create" != yes; then - ac_cs_success=: - ac_config_status_args= - test "$silent" = yes && - ac_config_status_args="$ac_config_status_args --quiet" - exec 5>/dev/null - $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. - $ac_cs_success || { (exit 1); exit 1; } -fi - - -# show the user what the variables have been set to -cat </dev/null 2>&1; then - return 0 - else - return 1 - fi -} - - -# -------------- portable configuration ---------------- -# this specifies the root of the source tree; it's just the -# directory where ./configure runs, except on cygwin, which -# overrides this below -CILHOME=`pwd` - -DEFAULT_COMPILER=_GNUCC -DEFAULT_CIL_MODE=GNUCC - -# is the microsoft compiler available? -# hmm.. I think we should check the version or something, because -# sometimes people have Common Lisp's interpreter called 'cl' .. -AC_MSG_CHECKING(for msvc cl.exe (optional)) -# See if CC points to the MS compiler -if "$CC" 2>&1 | grep "Microsoft" >/dev/null; then - AC_MSG_RESULT([found, set as default]) - HAS_MSVC=yes - DEFAULT_COMPILER=_MSVC - DEFAULT_CIL_MODE=MSVC -else - if cl 2>&1 | grep "Microsoft" >/dev/null ;then - AC_MSG_RESULT(found) - HAS_MSVC=yes - else - AC_MSG_RESULT(not found) - HAS_MSVC=no - fi -fi - -# is ocaml available? -# needed binaries: ocamllex ocamlyacc ocamldep ocamlopt ocamlc -ocamlDownloadInstructions=" - OCaml can be downloaded from http://caml.inria.fr/ocaml/. - After downloading and unpacking the source distribution, in the ocaml - directory, do - ./configure - make world - make opt - make install - Then come back here and re-run ./configure." - -# required major/minor. -# required major/minor -reqMaj=3 -reqMin=08 -knownMaj=3 -knownMin=09 -AC_MSG_CHECKING(ocaml version is at least $reqMaj.$reqMin) -if binaryExists ocamlc; then - # what version? - ver=`ocamlc -v | grep version | sed 's/^.*version //'` - diagnostic "ver is $ver" - # major: anything before the . - major=`echo $ver | sed 's/\..*$//'` - diagnostic "major is $major" - # minor: numbers after the . - # (the outer level of bracket-quotation protects the inner brackets) - [minor=`echo $ver | sed 's/^[^.]*\.\([0-9][0-9]*\).*$/\1/'`] - diagnostic "minor is $minor" - - # I would think autoconf would already have a facility for doing - # these kinds of major/minor version checks, but I can't find it - if test $major -gt $reqMaj -o $major -ge $reqMaj -a $minor -ge $reqMin; then - AC_MSG_RESULT([version is $ver, ok]) - - # sm: added this test when we found that CCured needed to be changed - # a little when 3.06 came out (it had previously worked with 3.04) - if test "$major" -gt $knownMaj -o "$major" -ge $knownMaj -a "$minor" -gt $knownMin; then - AC_MSG_WARN([Your ocaml version is $ver, but the latest version this program - is known to work with is $knownMaj.$knownMin. If you have - trouble compiling, please try using an earlier version - or see if there is a later version of this program.]) - fi - else - AC_MSG_ERROR([ - I found OCaml version $ver; this program requires at least $reqMaj.$reqMin. - Please download a newer OCaml distribution. - $ocamlDownloadInstructions - ]) - fi - - # check for existence of other binaries - AC_MSG_CHECKING(existence of related ocaml tools) - if binaryExists ocamllex && \ - binaryExists ocamlyacc && \ - binaryExists ocamldep && \ - binaryExists ocamlopt; then - AC_MSG_RESULT(ok) - else - AC_MSG_ERROR([ - At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing. - In particular, ocamlopt requires you to "make opt" when building - OCaml from source. Please make sure all these tools are built and - in the path. - ]) - fi -else - AC_MSG_ERROR([ - The "ocamlc" OCaml compiler was not found in the path: $PATH. - - Most of this program is written in the OCaml language, so its compiler - is required. - $ocamlDownloadInstructions - ]) -fi - -# -# ------------------- Perl ---------------- -# -AC_MSG_CHECKING([for Perl]) - if ! binaryExists perl; then - AC_MSG_ERROR([ - perl not found. - You need perl version 5.6.1 or later for CIL. - You can get perl at http://www.cpan.org/src/index.html . - ]) - fi - - # sm: oh how nice it would be to just say "use English; - # print($PERL_VERSION)", but that appears broken on 5.6.1.. so I'm - # trying to say "caret right-bracket", but then that would run afoul - # of autoconf's quoting characters, so I use the "quadrigraph" @:>@ - # to stand for right-bracket. what a mess. - perlver=`perl -e 'print($@:>@);'` - if perl -e "exit( $perlver >= 5.006001 );"; then - AC_MSG_ERROR([ - Found perl version $perlver, but at least 5.6.1 is required. - You can get a newer perl at http://www.cpan.org/src/index.html . - ]) - fi - - perlport=`perl -e "print $^O;"` - case "$perlport" in - cygwin) - ;; - MSWin32) # ActivePerl - ;; - linux) - ;; - freebsd) - ;; - openbsd) - ;; - darwin) # Mac OS X - ;; - solaris) - ;; - *) - AC_MSG_ERROR([ - Unsupported Perl port $perlport -- sorry. - cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin, - and solaris are the supported ports. - ]) - esac -AC_MSG_RESULT([found version $perlver, port $perlport]) - - # The cygwin port has some bugs in the File::Spec module -if test "$perlport" = "cygwin" ;then - AC_MSG_CHECKING([for known cygwin Perl bug in File::Spec]) - perlfixres=[`perl -e ' - use File::Spec; - if(File::Spec->file_name_is_absolute("C:/test")) { - print "no bug found"; exit 0; - } else { - print "bug"; - foreach $d (@INC) { - if(-f "$d/File/Spec/Unix.pm") { - open(IN, "<$d/File/Spec/Unix.pm"); - open(OUT, ">$d/File/Spec/Unix.pm.fixed") - || die "Cannot open $d/File/Spec/Unix.pm.fixed"; - while() { - if($_ =~ m|sub file_name_is_absolute|) { - print OUT $_; - print OUT scalar(); - print OUT <file_name_is_absolute("C:/test")) { - print "bug fixed"; exit 0; - } else { - print "cannot fix bug"; exit 1; - }'` - fi - if test "x$perlfixres" = "x" ;then - AC_MSG_ERROR([ - Cannot run perl - ]) - elif test "$perlfixres" = "cannot fix bug" ;then - AC_MSG_ERROR([ - Found a bug but cannot fix it. - ]) - else - AC_MSG_RESULT([$perlfixres]) - fi -fi - -# -# Now setup the performance counters -# -AC_MSG_CHECKING(if performance counters are usable) -# Create a C file from src/perfcount.c.in -rm -f ./cycles.exe -if gcc -DCONFIGURATION_ONLY \ - -x c ocamlutil/perfcount.c.in -lm -o ./cycles.exe >/dev/null 2>&1; then - - if CYCLES_PER_USEC=`./cycles.exe 2>&1` ;then - AC_MSG_RESULT([ok ($CYCLES_PER_USEC cycles per us)]) - else - # Print what we got - AC_MSG_RESULT([no ($CYCLES_PER_USEC)]) - CYCLES_PER_USEC=0 - fi -else - CYCLES_PER_USEC=0 - AC_MSG_RESULT([no (cannot compile perfcount.c)]) -fi -rm -f ./cycles.exe - -# If we are on Linux and we use performance counters try to get -# the processor speed from /proc/cpuinfo -if test "$CYCLES_PER_USEC" != "0" ;then - case "$target" in - # linux - *86*linux*) - AC_MSG_CHECKING(if /proc/cpuinfo has processor speed) - cpuinfo=`cat /proc/cpuinfo 2>/dev/null | grep "cpu MHz"` - [procspeed=`echo $cpuinfo | sed 's/^.*[^0-9]\([0-9]\+\.[0-9]\+\).*$/\1/g'`] - if test "$procspeed"!="" ;then - CYCLES_PER_USEC=$procspeed - AC_MSG_RESULT([got $CYCLES_PER_USEC cycles per us]) - else - AC_MSG_RESULT(no) - fi - ;; - *) - ;; - esac - # Now set HAS_PERFCOUNT - HAS_PERFCOUNT=1 -else - HAS_PERFCOUNT=0 -fi - -# additional tools we might check for: -# - gnu make - -# -# -------------------- GCC -------------- -# - -AC_MSG_CHECKING([for gcc version]) -AC_CHECK_TYPE(__builtin_va_list, - HAVE_BUILTIN_VA_LIST=true, - HAVE_BUILTIN_VA_LIST=false) -AC_MSG_CHECKING([if __thread is a keyword]) -AC_COMPILE_IFELSE([int main(int __thread) { return 0; }], - THREAD_IS_KEYWORD=false, - THREAD_IS_KEYWORD=true) -AC_MSG_RESULT($THREAD_IS_KEYWORD) - -# Does gcc add underscores to identifiers to make assembly labels? -# (I think MSVC always does) -AC_MSG_CHECKING([if gcc adds underscores to assembly labels.]) -AC_LINK_IFELSE([int main() { __asm__("jmp _main"); }], - UNDERSCORE_NAME=true, - UNDERSCORE_NAME=false) -AC_MSG_RESULT($UNDERSCORE_NAME) - - -# ----------- some stuff 'autoscan' put here -------------- -# (autoscan is part of the autoconf distribution) - -# checks for header files -AC_HEADER_STDC -AC_CHECK_HEADERS(stdlib.h strings.h sys/time.h unistd.h wchar.h) - -# checks for typedefs, structures, and compiler characteristics -AC_C_CONST -AC_C_INLINE -AC_HEADER_TIME - -# checks for library functions; more autoscan stuff -AC_FUNC_MEMCMP -AC_CHECK_FUNCS(mkdir select socket __sysv_signal) - - - -# ----------- platform-specific code ------------- -# $target is typically processor-vendor-os -case "$target" in - # linux - *86*linux*|*86*freebsd*|*86*openbsd*|*86*darwin*) - AC_MSG_RESULT(configuring for linux/x86) - - ARCHOS=x86_LINUX - ;; - - # Mac OS X - *powerpc*darwin*) - AC_MSG_RESULT(configuring for powerpc/darwin, which we treat like linux/x86) - - ARCHOS=ppc_DARWIN - ;; - - # cygwin - *86*cygwin*) - AC_MSG_RESULT(configuring for Cygwin on win32/x86) - - ARCHOS=x86_WIN32 - - # override CILHOME; even on cygwin we want forward slashes - # sm: I folded this into what I hope will be the only - # case-analysis of machine type - CILHOME=`cygpath -wa "$CILHOME" | sed -e "s/\\\\\/\\//g"` - CC=`which $CC` - CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"` - ;; - - # Solaris - *sparc*solaris*) - AC_MSG_RESULT(configuring for SPARC/Solaris) - - ARCHOS=sparc_SOLARIS - ;; - - *) - AC_MSG_ERROR([ - Unsupported platform $target -- sorry. - ./configure supports these platforms: - on x86: Linux, Win32(with Cygwin), freeBSD, openBSD, and Mac OS X - on PowerPC: Mac OS X - on SPARC: Solaris - ]) - ;; -esac - -# Make the object directory if not already present -AC_CHECK_FILE(obj/$ARCHOS,, AC_MSG_RESULT(creating obj/$ARCHOS); - mkdir -p obj/$ARCHOS) - -AC_MSG_CHECKING([delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file]) -rm -f obj/$ARCHOS/machdep.ml -rm -f obj/.depend/machdep.d -rm -f obj/$ARCHOS/feature_config.ml -rm -f obj/.depend/feature_config.d -AC_MSG_RESULT([done]) - -# We will use substitution variables whose definition contains newlines. The -# problem is that when config.status runs, it wants to break the series of -# substitution commands for sed into fragments based on line count. We could -# be unlucky and have config.status break the series of substitution in the -# middle of a variable that contains newlines. So, we first create a single -# variable called NEWLINE whose definition is a carriage return. This means -# that there will be exactly one opportunity for this error to happen (in the -# definition of NEWLINE). The occurrence of AC_SUBST for NEWLINE must occur -# after those of the variables that use it! And we want to put all of these -# very early on, to make sure that they are not around the place when the file -# bets broken. - -NEWLINE="\\ -" - - -# -# CIL/CCured features -# -# - -# Set the defaults - - -# Give a space-separated list of features with the defaults -features="blockinggraph=no rand=no arithabs=no zrapp=no" - -AC_ARG_WITH(blockinggraph, - AC_HELP_STRING([--with-blockinggraph], - [enable the blocking graph feature])) -AC_ARG_WITH(rand, - AC_HELP_STRING([--with-rand], - [enable the randomized value numbering])) -AC_ARG_WITH(arithabs, - AC_HELP_STRING([--with-arithabs], - [enable the arithmetic abstraction])) -AC_ARG_WITH(zrapp, - AC_HELP_STRING([--with-zrapp], - [enable the zrapp pretty-printer])) - -# Smalloc.ml is distributed by {matth,nks}@cs.berkeley.edu as part of Scrash. -features="$features smalloc=no" - -# cqualann.ml is used by Matt Harren. Please ignore. -features="$features cqualann=no" - -# Now add any features specified in the command-line - -features="$features $EXTRAFEATURES" - -for f_val in $features -do - # If there is no =, then we default to yes - if ! (echo $f_val | grep "=" >/dev/null) ;then f_val="$f_val=yes"; fi - # echo "Testing feature $f_val" - f=`echo $f_val | sed -e s%=.*$%%` - AC_MSG_CHECKING(whether to use CIL feature $f) - # default value from "features" - defval=`echo $f_val | sed -e s%^.*=%%` - # current value - getcurval="echo \${with_$f:=$defval}" - curval=`eval $getcurval` - AC_MSG_RESULT($curval) - if test $curval = yes ;then - CIL_FEATURES="$CIL_FEATURES $f" - fi -done - -## Now produce the CIL_FEATURES_DEFINES -CIL_FEATURES_DEFINES="" -# Convert to upper case -for f in `echo $CIL_FEATURES | tr a-z A-Z` -do - CIL_FEATURES_DEFINES="${CIL_FEATURES_DEFINES}@NEWLINE@export USE_$f=yes" -done - - -# ----------------- finish up ------------------- -# names of the variables that get substituted in files; for example, -# write @ARCHOS@ somewhere in a written file to get it substituted -AC_SUBST(ARCHOS) -AC_SUBST(CILHOME) -AC_SUBST(HAS_MSVC) -AC_SUBST(DEFAULT_COMPILER) -AC_SUBST(DEFAULT_CIL_MODE) -AC_SUBST(CIL_VERSION_MAJOR) -AC_SUBST(CIL_VERSION_MINOR) -AC_SUBST(CIL_VERSION_REV) -AC_SUBST(CIL_VERSION) -AC_SUBST(CYCLES_PER_USEC) -AC_SUBST(HAS_PERFCOUNT) -AC_SUBST(HAVE_BUILTIN_VA_LIST) -AC_SUBST(THREAD_IS_KEYWORD) -AC_SUBST(UNDERSCORE_NAME) -AC_SUBST(EXTRAFEATURES) -AC_SUBST(EXTRASRCDIRS) - -# finish the configure script and generate various files; ./configure -# will apply variable substitutions to .in to generate ; -# I find it useful to mark generated files as read-only so I don't -# accidentally edit them (and them lose my changes when ./configure -# runs again); I had originally done the chmod after AC_OUTPUT, but -# the problem is then the chmod doesn't run inside ./config.status - -# MY_AC_CONFIG_FILES(filename) -# do AC_CONFIG_FILES(filename, chmod a-w filename) -define([MY_AC_CONFIG_FILES], -[{ - if test -f [$1].in; then - AC_CONFIG_FILES([$1], chmod a-w [$1]) - else - true - #echo "skipping [$1] because it's not in this distribution" - fi -}]) -define([MY_AC_CONFIG_EXE_FILES], -[{ - if test -f [$1].in; then - AC_CONFIG_FILES([$1], [chmod a-w,a+x $1]) - else - true - #echo "skipping [$1] because it's not in this distribution" - fi -}]) - -MY_AC_CONFIG_FILES(Makefile) -MY_AC_CONFIG_FILES(cil.spec) -MY_AC_CONFIG_FILES(config.mk) -MY_AC_CONFIG_FILES(test/Makefile) -MY_AC_CONFIG_EXE_FILES(bin/cilly.bat) -MY_AC_CONFIG_EXE_FILES(bin/patcher.bat) -MY_AC_CONFIG_FILES(bin/CilConfig.pm) -MY_AC_CONFIG_FILES(doc/index.html) -MY_AC_CONFIG_FILES(doc/header.html) -MY_AC_CONFIG_FILES(ocamlutil/perfcount.c) - -AC_OUTPUT() - -# show the user what the variables have been set to -cat < - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Alpha - - -
Previous - Up - Next -
-

Module Alpha

-
-
module Alpha: sig .. end
ALPHA conversion
-
-
type 'a undoAlphaElement
-
-This is the type of the elements that are recorded by the alpha - conversion functions in order to be able to undo changes to the tables - they modify. Useful for implementing - scoping
-
- -
type 'a alphaTableData
-
-This is the type of the elements of the alpha renaming table. These - elements can carry some data associated with each occurrence of the name.
-
- -
val newAlphaName : alphaTable:(string, 'a alphaTableData Pervasives.ref) Hashtbl.t ->
       undolist:'a undoAlphaElement list Pervasives.ref option ->
       lookupname:string -> data:'a -> string * 'a
-Create a new name based on a given name. The new name is formed from a - prefix (obtained from the given name by stripping a suffix consisting of _ - followed by only digits), followed by a special separator and then by a - positive integer suffix. The first argument is a table mapping name - prefixes to some data that specifies what suffixes have been used and how - to create the new one. This function updates the table with the new - largest suffix generated. The "undolist" argument, when present, will be - used by the function to record information that can be used by - Alpha.undoAlphaChanges to undo those changes. Note that the undo - information will be in reverse order in which the action occurred. Returns - the new name and, if different from the lookupname, the location of the - previous occurrence. This function knows about the location implicitly - from the Cil.currentLoc.
-
-
val registerAlphaName : alphaTable:(string, 'a alphaTableData Pervasives.ref) Hashtbl.t ->
       undolist:'a undoAlphaElement list Pervasives.ref option ->
       lookupname:string -> data:'a -> unit
-Register a name with an alpha conversion table to ensure that when later - we call newAlphaName we do not end up generating this one
-
-
val docAlphaTable : unit ->
       (string, 'a alphaTableData Pervasives.ref) Hashtbl.t -> Pretty.doc
-Split the name in preparation for newAlphaName. The prefix returned is - used to index into the hashtable. The next result value is a separator - (either empty or the separator chosen to separate the original name from - the index)
-
-
val getAlphaPrefix : lookupname:string -> string
val undoAlphaChanges : alphaTable:(string, 'a alphaTableData Pervasives.ref) Hashtbl.t ->
       undolist:'a undoAlphaElement list -> unit
-Undo the changes to a table
-
- \ No newline at end of file diff --git a/cil/doc/api/Cfg.html b/cil/doc/api/Cfg.html deleted file mode 100644 index 142de8a..0000000 --- a/cil/doc/api/Cfg.html +++ /dev/null @@ -1,69 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cfg - - -
Previous - Up - Next -
-

Module Cfg

-
-
module Cfg: sig .. end
Code to compute the control-flow graph of a function or file. - This will fill in the preds and succs fields of Cil.stmt -

- - This is required for several other extensions, such as Dataflow.
-

-
val computeFileCFG : Cil.file -> unit
-Compute the CFG for an entire file, by calling cfgFun on each function.
-
-
val clearFileCFG : Cil.file -> unit
-clear the sid, succs, and preds fields of each statement.
-
-
val cfgFun : Cil.fundec -> int
-Compute a control flow graph for fd. Stmts in fd have preds and succs - filled in
-
-
val clearCFGinfo : Cil.fundec -> unit
-clear the sid, succs, and preds fields of each statment in a function
-
-
val printCfgChannel : Pervasives.out_channel -> Cil.fundec -> unit
-print control flow graph (in dot form) for fundec to channel
-
-
val printCfgFilename : string -> Cil.fundec -> unit
-Print control flow graph (in dot form) for fundec to file
-
-
val start_id : int Pervasives.ref
-Next statement id that will be assigned.
-
-
val nodeList : Cil.stmt list Pervasives.ref
-All of the nodes in a file.
-
-
val numNodes : int Pervasives.ref
-number of nodes in the CFG
-
- \ No newline at end of file diff --git a/cil/doc/api/Cil.cilPrinter.html b/cil/doc/api/Cil.cilPrinter.html deleted file mode 100644 index 1b9511f..0000000 --- a/cil/doc/api/Cil.cilPrinter.html +++ /dev/null @@ -1,118 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.cilPrinter - - -
Previous - Up - 
-

Class type Cil.cilPrinter

-
-
class type cilPrinter = object .. end
A printer interface for CIL trees. Create instantiations of - this type by specializing the class Cil.defaultCilPrinterClass.
-
-
method pVDecl : unit -> varinfo -> Pretty.doc
-Invoked for each variable declaration. Note that variable - declarations are all the GVar, GVarDecl, GFun, all the varinfo - in formals of function types, and the formals and locals for function - definitions.
-
-
method pVar : varinfo -> Pretty.doc
-Invoked on each variable use.
-
-
method pLval : unit -> lval -> Pretty.doc
-Invoked on each lvalue occurrence
-
-
method pOffset : Pretty.doc -> offset -> Pretty.doc
-Invoked on each offset occurrence. The second argument is the base.
-
-
method pInstr : unit -> instr -> Pretty.doc
-Invoked on each instruction occurrence.
-
-
method pLabel : unit -> label -> Pretty.doc
-Print a label.
-
-
method pStmt : unit -> stmt -> Pretty.doc
-Control-flow statement. This is used by - Cil.printGlobal and by Cil.dumpGlobal.
-
-
method dStmt : Pervasives.out_channel -> int -> stmt -> unit
-Dump a control-flow statement to a file with a given indentation. - This is used by Cil.dumpGlobal.
-
-
method dBlock : Pervasives.out_channel -> int -> block -> unit
-Dump a control-flow block to a file with a given indentation. - This is used by Cil.dumpGlobal.
-
-
method pBlock : unit -> block -> Pretty.doc
method pBlock : unit -> block -> Pretty.doc
-Print a block.
-
-
method pGlobal : unit -> global -> Pretty.doc
-Global (vars, types, etc.). This can be slow and is used only by - Cil.printGlobal but not by Cil.dumpGlobal.
-
-
method dGlobal : Pervasives.out_channel -> global -> unit
-Dump a global to a file with a given indentation. This is used by - Cil.dumpGlobal
-
-
method pFieldDecl : unit -> fieldinfo -> Pretty.doc
-A field declaration
-
-
method pType : Pretty.doc option -> unit -> typ -> Pretty.doc
method pAttr : attribute -> Pretty.doc * bool
-Attribute. Also return an indication whether this attribute must be - printed inside the __attribute__ list or not.
-
-
method pAttrParam : unit -> attrparam -> Pretty.doc
-Attribute parameter
-
-
method pAttrs : unit -> attributes -> Pretty.doc
-Attribute lists
-
-
method pLineDirective : ?forcefile:bool -> location -> Pretty.doc
-Print a line-number. This is assumed to come always on an empty line. - If the forcefile argument is present and is true then the file name - will be printed always. Otherwise the file name is printed only if it - is different from the last time time this function is called. The last - file name is stored in a private field inside the cilPrinter object.
-
-
method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc
-Print a statement kind. The code to be printed is given in the - Cil.stmtkind argument. The initial Cil.stmt argument - records the statement which follows the one being printed; - Cil.defaultCilPrinterClass uses this information to prettify - statement printing in certain special cases.
-
-
method pExp : unit -> exp -> Pretty.doc
-Print expressions
-
-
method pInit : unit -> init -> Pretty.doc
-Print initializers. This can be slow and is used by - Cil.printGlobal but not by Cil.dumpGlobal.
-
-
method dInit : Pervasives.out_channel -> int -> init -> unit
-Dump a global to a file with a given indentation. This is used by - Cil.dumpGlobal
-
- \ No newline at end of file diff --git a/cil/doc/api/Cil.cilVisitor.html b/cil/doc/api/Cil.cilVisitor.html deleted file mode 100644 index f8c6496..0000000 --- a/cil/doc/api/Cil.cilVisitor.html +++ /dev/null @@ -1,125 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.cilVisitor - - -
 Up - Next -
-

Class type Cil.cilVisitor

-
-
class type cilVisitor = object .. end
A visitor interface for traversing CIL trees. Create instantiations of - this type by specializing the class Cil.nopCilVisitor. Each of the - specialized visiting functions can also call the queueInstr to specify - that some instructions should be inserted before the current instruction - or statement. Use syntax like self#queueInstr to call a method - associated with the current object.
-
-
method vvdec : varinfo -> varinfo visitAction
-Invoked for each variable declaration. The subtrees to be traversed - are those corresponding to the type and attributes of the variable. - Note that variable declarations are all the GVar, GVarDecl, GFun, - all the varinfo in formals of function types, and the formals and - locals for function definitions. This means that the list of formals - in a function definition will be traversed twice, once as part of the - function type and second as part of the formals in a function - definition.
-
-
method vvrbl : varinfo -> varinfo visitAction
-Invoked on each variable use. Here only the SkipChildren and - ChangeTo actions make sense since there are no subtrees. Note that - the type and attributes of the variable are not traversed for a - variable use
-
-
method vexpr : exp -> exp visitAction
-Invoked on each expression occurrence. The subtrees are the - subexpressions, the types (for a Cast or SizeOf expression) or the - variable use.
-
-
method vlval : lval -> lval visitAction
-Invoked on each lvalue occurrence
-
-
method voffs : offset -> offset visitAction
-Invoked on each offset occurrence that is *not* as part - of an initializer list specification, i.e. in an lval or - recursively inside an offset.
-
-
method vinitoffs : offset -> offset visitAction
-Invoked on each offset appearing in the list of a - CompoundInit initializer.
-
-
method vinst : instr -> instr list visitAction
-Invoked on each instruction occurrence. The ChangeTo action can - replace this instruction with a list of instructions
-
-
method vstmt : stmt -> stmt visitAction
-Control-flow statement. The default DoChildren action does not - create a new statement when the components change. Instead it updates - the contents of the original statement. This is done to preserve the - sharing with Goto and Case statements that point to the original - statement. If you use the ChangeTo action then you should take care - of preserving that sharing yourself.
-
-
method vblock : block -> block visitAction
-Block.
-
-
method vfunc : fundec -> fundec visitAction
-Function definition. - Replaced in place.
-
-
method vglob : global -> global list visitAction
-Global (vars, types, - etc.)
-
-
method vinit : init -> init visitAction
-Initializers for globals
-
-
method vtype : typ -> typ visitAction
-Use of some type. Note - that for structure/union - and enumeration types the - definition of the - composite type is not - visited. Use vglob to - visit it.
-
-
method vattr : attribute -> attribute list visitAction
-Attribute. Each attribute can be replaced by a list
-
-
method vattrparam : attrparam -> attrparam visitAction
-Attribute parameters.
-
-
method queueInstr : instr list -> unit
-Add here instructions while visiting to queue them to preceede the - current statement or instruction being processed. Use this method only - when you are visiting an expression that is inside a function body, or - a statement, because otherwise there will no place for the visitor to - place your instructions.
-
-
method unqueueInstr : unit -> instr list
-Gets the queue of instructions and resets the queue. This is done - automatically for you when you visit statments.
-
- \ No newline at end of file diff --git a/cil/doc/api/Cil.defaultCilPrinterClass.html b/cil/doc/api/Cil.defaultCilPrinterClass.html deleted file mode 100644 index d859559..0000000 --- a/cil/doc/api/Cil.defaultCilPrinterClass.html +++ /dev/null @@ -1,36 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.defaultCilPrinterClass - - -
Previous - Up - Next -
-

Class Cil.defaultCilPrinterClass

-
-
class defaultCilPrinterClass : cilPrinter
- \ No newline at end of file diff --git a/cil/doc/api/Cil.html b/cil/doc/api/Cil.html deleted file mode 100644 index f2e09c2..0000000 --- a/cil/doc/api/Cil.html +++ /dev/null @@ -1,3337 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil - - -
Previous - Up - Next -
-

Module Cil

-
-
module Cil: sig .. end
CIL API Documentation. An html version of this document can be found at - http://manju.cs.berkeley.edu/cil.
-
-
val initCIL : unit -> unit
-Call this function to perform some initialization. Call if after you have - set Cil.msvcMode.
-
-
val cilVersion : string
-This are the CIL version numbers. A CIL version is a number of the form - M.m.r (major, minor and release)
-
-
val cilVersionMajor : int
val cilVersionMinor : int
val cilVersionRevision : int

-This module defines the abstract syntax of CIL. It also provides utility - functions for traversing the CIL data structures, and pretty-printing - them. The parser for both the GCC and MSVC front-ends can be invoked as - Frontc.parse: string -> unit -> Cil.file. This function must be given - the name of a preprocessed C file and will return the top-level data - structure that describes a whole source file. By default the parsing and - elaboration into CIL is done as for GCC source. If you want to use MSVC - source you must set the Cil.msvcMode to true and must also invoke the - function Frontc.setMSVCMode: unit -> unit.
-
-The Abstract Syntax of CIL
-
-The top-level representation of a CIL source file (and the result of the - parsing and elaboration). Its main contents is the list of global - declarations and definitions. You can iterate over the globals in a - Cil.file using the following iterators: Cil.mapGlobals, - Cil.iterGlobals and Cil.foldGlobals. You can also use the - Cil.dummyFile when you need a Cil.file as a placeholder. For each - global item CIL stores the source location where it appears (using the - type Cil.location)
-
type file = { - - - - - - - - - - - - - - - - - - - -
-   -mutable fileName : string;(*The complete file name*)
-   -mutable globals : global list;(*List of globals as they will appear - in the printed file*)
-   -mutable globinit : fundec option;(*An optional global initializer function. This is a function where - you can put stuff that must be executed before the program is - started. This function, is conceptually at the end of the file, - although it is not part of the globals list. Use Cil.getGlobInit - to create/get one.*)
-   -mutable globinitcalled : bool;(*Whether the global initialization function is called in main. This - should always be false if there is no global initializer. When you - create a global initialization CIL will try to insert code in main - to call it. This will not happen if your file does not contain a - function called "main"*)
-} - -
-Top-level representation of a C source file
-
- -
type comment = location * string
- -
-Globals. The main type for representing global declarations and - definitions. A list of these form a CIL file. The order of globals in the - file is generally important.
-
type global = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -GType of typeinfo * location(*A typedef. All uses of type names (through the TNamed constructor) - must be preceded in the file by a definition of the name. The string - is the defined name and always not-empty.*)
-| -GCompTag of compinfo * location(*Defines a struct/union tag with some fields. There must be one of - these for each struct/union tag that you use (through the TComp - constructor) since this is the only context in which the fields are - printed. Consequently nested structure tag definitions must be - broken into individual definitions with the innermost structure - defined first.*)
-| -GCompTagDecl of compinfo * location(*Declares a struct/union tag. Use as a forward declaration. This is - printed without the fields.*)
-| -GEnumTag of enuminfo * location(*Declares an enumeration tag with some fields. There must be one of - these for each enumeration tag that you use (through the TEnum - constructor) since this is the only context in which the items are - printed.*)
-| -GEnumTagDecl of enuminfo * location(*Declares an enumeration tag. Use as a forward declaration. This is - printed without the items.*)
-| -GVarDecl of varinfo * location(*A variable declaration (not a definition). If the variable has a - function type then this is a prototype. There can be several - declarations and at most one definition for a given variable. If both - forms appear then they must share the same varinfo structure. A - prototype shares the varinfo with the fundec of the definition. Either - has storage Extern or there must be a definition in this file*)
-| -GVar of varinfo * initinfo * location(*A variable definition. Can have an initializer. The initializer is - updateable so that you can change it without requiring to recreate - the list of globals. There can be at most one definition for a - variable in an entire program. Cannot have storage Extern or function - type.*)
-| -GFun of fundec * location(*A function definition.*)
-| -GAsm of string * location(*Global asm statement. These ones - can contain only a template*)
-| -GPragma of attribute * location(*Pragmas at top level. Use the same - syntax as attributes*)
-| -GText of string(*Some text (printed verbatim) at - top level. E.g., this way you can - put comments in the output.*)
- -
-A global declaration or definition
-
- -
-Types. A C type is represented in CIL using the type Cil.typ. - Among types we differentiate the integral types (with different kinds - denoting the sign and precision), floating point types, enumeration types, - array and pointer types, and function types. Every type is associated with - a list of attributes, which are always kept in sorted order. Use - Cil.addAttribute and Cil.addAttributes to construct list of - attributes. If you want to inspect a type, you should use - Cil.unrollType or Cil.unrollTypeDeep to see through the uses of - named types.
-
-CIL is configured at build-time with the sizes and alignments of the - underlying compiler (GCC or MSVC). CIL contains functions that can compute - the size of a type (in bits) Cil.bitsSizeOf, the alignment of a type - (in bytes) Cil.alignOf_int, and can convert an offset into a start and - width (both in bits) using the function Cil.bitsOffset. At the moment - these functions do not take into account the packed attributes and - pragmas.
-
type typ = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -TVoid of attributes(*Void type. Also predefined as Cil.voidType*)
-| -TInt of ikind * attributes(*An integer type. The kind specifies the sign and width. Several - useful variants are predefined as Cil.intType, Cil.uintType, - Cil.longType, Cil.charType.*)
-| -TFloat of fkind * attributes(*A floating-point type. The kind specifies the precision. You can - also use the predefined constant Cil.doubleType.*)
-| -TPtr of typ * attributes(*Pointer type. Several useful variants are predefined as - Cil.charPtrType, Cil.charConstPtrType (pointer to a - constant character), Cil.voidPtrType, - Cil.intPtrType*)
-| -TArray of typ * exp option * attributes(*Array type. It indicates the base type and the array length.*)
-| -TFun of typ * (string * typ * attributes) list option * bool
* attributes		(*Function type. Indicates the type of the result, the name, type - and name attributes of the formal arguments (None if no - arguments were specified, as in a function whose definition or - prototype we have not seen; Some [] means void). Use - Cil.argsToList to obtain a list of arguments. The boolean - indicates if it is a variable-argument function. If this is the - type of a varinfo for which we have a function declaration then - the information for the formals must match that in the - function's sformals. Use Cil.setFormals, or - Cil.setFunctionType, or Cil.makeFormalVar for this - purpose.*)
-| -TNamed of typeinfo * attributes
-| -TComp of compinfo * attributes(*The most delicate issue for C types is that recursion that is possible by - using structures and pointers. To address this issue we have a more - complex representation for structured types (struct and union). Each such - type is represented using the Cil.compinfo type. For each composite - type the Cil.compinfo structure must be declared at top level using - GCompTag and all references to it must share the same copy of the - structure. The attributes given are those pertaining to this use of the - type and are in addition to the attributes that were given at the - definition of the type and which are stored in the Cil.compinfo.*)
-| -TEnum of enuminfo * attributes(*A reference to an enumeration type. All such references must - share the enuminfo among them and with a GEnumTag global that - precedes all uses. The attributes refer to this use of the - enumeration and are in addition to the attributes of the - enumeration itself, which are stored inside the enuminfo*)
-| -TBuiltin_va_list of attributes(*This is the same as the gcc's type with the same name*)
- - -
-There are a number of functions for querying the kind of a type. These are - Cil.isIntegralType, - Cil.isArithmeticType, - Cil.isPointerType, - Cil.isFunctionType, - Cil.isArrayType. -

- - There are two easy ways to scan a type. First, you can use the -Cil.existsType to return a boolean answer about a type. This function -is controlled by a user-provided function that is queried for each type that is -used to construct the current type. The function can specify whether to -terminate the scan with a boolean result or to continue the scan for the -nested types. -

- - The other method for scanning types is provided by the visitor interface (see - Cil.cilVisitor). -

- - If you want to compare types (or to use them as hash-values) then you should -use instead type signatures (represented as Cil.typsig). These -contain the same information as types but canonicalized such that simple Ocaml -structural equality will tell whether two types are equal. Use -Cil.typeSig to compute the signature of a type. If you want to ignore -certain type attributes then use Cil.typeSigWithAttrs.
-
type ikind = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -IChar(*char*)
-| -ISChar(*signed char*)
-| -IUChar(*unsigned char*)
-| -IInt(*int*)
-| -IUInt(*unsigned int*)
-| -IShort(*short*)
-| -IUShort(*unsigned short*)
-| -ILong(*long*)
-| -IULong(*unsigned long*)
-| -ILongLong(*long long (or _int64 on Microsoft Visual C)*)
-| -IULongLong(*unsigned long long (or unsigned _int64 on Microsoft - Visual C)*)
- -

-Various kinds of integers
-
- -
type fkind = - - - - - - - - - - - - - - -
-| -FFloat(*float*)
-| -FDouble(*double*)
-| -FLongDouble(*long double*)
- -
-Various kinds of floating-point numbers
-
- -
-Attributes.
-
type attribute = - - - - -
-| -Attr of string * attrparam list(*An attribute has a name and some optional parameters. The name should not - start or end with underscore. When CIL parses attribute names it will - strip leading and ending underscores (to ensure that the multitude of GCC - attributes such as const, __const and __const__ all mean the same thing.)*)
- - -
type attributes = attribute list
-
-Attributes are lists sorted by the attribute name. Use the functions - Cil.addAttribute and Cil.addAttributes to insert attributes in an - attribute list and maintain the sortedness.
-
- -
type attrparam = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -AInt of int(*An integer constant*)
-| -AStr of string(*A string constant*)
-| -ACons of string * attrparam list(*Constructed attributes. These - are printed foo(a1,a2,...,an). - The list of parameters can be - empty and in that case the - parentheses are not printed.*)
-| -ASizeOf of typ(*A way to talk about types*)
-| -ASizeOfE of attrparam
-| -ASizeOfS of typsig(*Replacement for ASizeOf in type - signatures. Only used for - attributes inside typsigs.*)
-| -AAlignOf of typ
-| -AAlignOfE of attrparam
-| -AAlignOfS of typsig
-| -AUnOp of unop * attrparam
-| -ABinOp of binop * attrparam * attrparam
-| -ADot of attrparam * string(*a.foo **)
- -
-The type of parameters of attributes
-
- -
-Structures. The Cil.compinfo describes the definition of a - structure or union type. Each such Cil.compinfo must be defined at the - top-level using the GCompTag constructor and must be shared by all - references to this type (using either the TComp type constructor or from - the definition of the fields. -

- - If all you need is to scan the definition of each - composite type once, you can do that by scanning all top-level GCompTag. -

- - Constructing a Cil.compinfo can be tricky since it must contain fields - that might refer to the host Cil.compinfo and furthermore the type of - the field might need to refer to the Cil.compinfo for recursive types. - Use the Cil.mkCompInfo function to create a Cil.compinfo. You can - easily fetch the Cil.fieldinfo for a given field in a structure with - Cil.getCompField.
-
type compinfo = { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-   -mutable cstruct : bool;(*True if struct, False if union*)
-   -mutable cname : string;(*The name. Always non-empty. Use Cil.compFullName to get the full - name of a comp (along with the struct or union)*)
-   -mutable ckey : int;(*A unique integer. This is assigned by Cil.mkCompInfo using a - global variable in the Cil module. Thus two identical structs in two - different files might have different keys. Use Cil.copyCompInfo to - copy structures so that a new key is assigned.*)
-   -mutable cfields : fieldinfo list;(*Information about the fields. Notice that each fieldinfo has a - pointer back to the host compinfo. This means that you should not - share fieldinfo's between two compinfo's*)
-   -mutable cattr : attributes;(*The attributes that are defined at the same time as the composite - type. These attributes can be supplemented individually at each - reference to this compinfo using the TComp type constructor.*)
-   -mutable cdefined : bool;(*This boolean flag can be used to distinguish between structures - that have not been defined and those that have been defined but have - no fields (such things are allowed in gcc).*)
-   -mutable creferenced : bool;(*True if used. Initially set to false.*)
-} - -

-The definition of a structure or union type. Use Cil.mkCompInfo to - make one and use Cil.copyCompInfo to copy one (this ensures that a new - key is assigned and that the fields have the right pointers to parents.).
-
- -
-Structure fields. The Cil.fieldinfo structure is used to describe - a structure or union field. Fields, just like variables, can have - attributes associated with the field itself or associated with the type of - the field (stored along with the type of the field).
-
type fieldinfo = { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-   -mutable fcomp : compinfo;(*The host structure that contains this field. There can be only one - compinfo that contains the field.*)
-   -mutable fname : string;(*The name of the field. Might be the value of Cil.missingFieldName - in which case it must be a bitfield and is not printed and it does not - participate in initialization*)
-   -mutable ftype : typ;(*The type*)
-   -mutable fbitfield : int option;(*If a bitfield then ftype should be an integer type and the width of - the bitfield must be 0 or a positive integer smaller or equal to the - width of the integer type. A field of width 0 is used in C to control - the alignment of fields.*)
-   -mutable fattr : attributes;(*The attributes for this field (not for its type)*)
-   -mutable floc : location;(*The location where this field is defined*)
-} - -
-Information about a struct/union field
-
- -
-Enumerations. Information about an enumeration. This is shared by all - references to an enumeration. Make sure you have a GEnumTag for each of - of these.
-
type enuminfo = { - - - - - - - - - - - - - - - - - - - -
-   -mutable ename : string;(*The name. Always non-empty.*)
-   -mutable eitems : (string * exp * location) list;(*Items with names and values. This list should be non-empty. The item - values must be compile-time constants.*)
-   -mutable eattr : attributes;(*The attributes that are defined at the same time as the enumeration - type. These attributes can be supplemented individually at each - reference to this enuminfo using the TEnum type constructor.*)
-   -mutable ereferenced : bool;(*True if used. Initially set to false*)
-} - -
-Information about an enumeration
-
- -
-Enumerations. Information about an enumeration. This is shared by all - references to an enumeration. Make sure you have a GEnumTag for each of - of these.
-
type typeinfo = { - - - - - - - - - - - - - - -
-   -mutable tname : string;(*The name. Can be empty only in a GType when introducing a composite - or enumeration tag. If empty cannot be referred to from the file*)
-   -mutable ttype : typ;(*The actual type. This includes the attributes that were present in - the typedef*)
-   -mutable treferenced : bool;(*True if used. Initially set to false*)
-} - -
-Information about a defined type
-
- -
-Variables. - Each local or global variable is represented by a unique Cil.varinfo -structure. A global Cil.varinfo can be introduced with the GVarDecl or -GVar or GFun globals. A local varinfo can be introduced as part of a -function definition Cil.fundec. -

- - All references to a given global or local variable must refer to the same -copy of the varinfo. Each varinfo has a globally unique identifier that -can be used to index maps and hashtables (the name can also be used for this -purpose, except for locals from different functions). This identifier is -constructor using a global counter. -

- - It is very important that you construct varinfo structures using only one - of the following functions:

- - A varinfo is also used in a function type to denote the list of formals.
-
type varinfo = { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-   -mutable vname : string;(*The name of the variable. Cannot be empty. It is primarily your - responsibility to ensure the uniqueness of a variable name. For local - variables Cil.makeTempVar helps you ensure that the name is unique.*)
-   -mutable vtype : typ;(*The declared type of the variable.*)
-   -mutable vattr : attributes;(*A list of attributes associated with the variable.*)
-   -mutable vstorage : storage;(*The storage-class*)
-   -mutable vglob : bool;(*True if this is a global variable*)
-   -mutable vinline : bool;(*Whether this varinfo is for an inline function.*)
-   -mutable vdecl : location;(*Location of variable declaration.*)
-   -mutable vid : int;(*A unique integer identifier. This field will be - set for you if you use one of the Cil.makeFormalVar, - Cil.makeLocalVar, Cil.makeTempVar, Cil.makeGlobalVar, or - Cil.copyVarinfo.*)
-   -mutable vaddrof : bool;(*True if the address of this variable is taken. CIL will set these - flags when it parses C, but you should make sure to set the flag - whenever your transformation create AddrOf expression.*)
-   -mutable vreferenced : bool;(*True if this variable is ever referenced. This is computed by - removeUnusedVars. It is safe to just initialize this to False*)
-} - -
-Information about a variable.
-
- -
type storage = - - - - - - - - - - - - - - - - - - - -
-| -NoStorage(*The default storage. Nothing is printed*)
-| -Static
-| -Register
-| -Extern
- -
-Storage-class information
-
- -
-Expressions. The CIL expression language contains only the side-effect free expressions of -C. They are represented as the type Cil.exp. There are several -interesting aspects of CIL expressions: -

- - Integer and floating point constants can carry their textual representation. -This way the integer 15 can be printed as 0xF if that is how it occurred in the -source. -

- - CIL uses 64 bits to represent the integer constants and also stores the width -of the integer type. Care must be taken to ensure that the constant is -representable with the given width. Use the functions Cil.kinteger, -Cil.kinteger64 and Cil.integer to construct constant -expressions. CIL predefines the constants Cil.zero, -Cil.one and Cil.mone (for -1). -

- - Use the functions Cil.isConstant and Cil.isInteger to test if -an expression is a constant and a constant integer respectively. -

- - CIL keeps the type of all unary and binary expressions. You can think of that -type qualifying the operator. Furthermore there are different operators for -arithmetic and comparisons on arithmetic types and on pointers. -

- - Another unusual aspect of CIL is that the implicit conversion between an -expression of array type and one of pointer type is made explicit, using the -StartOf expression constructor (which is not printed). If you apply the -AddrOf}constructor to an lvalue of type T then you will be getting an -expression of type TPtr(T). -

- - You can find the type of an expression with Cil.typeOf. -

- - You can perform constant folding on expressions using the function -Cil.constFold.
-
type exp = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -Const of constant(*Constant*)
-| -Lval of lval(*Lvalue*)
-| -SizeOf of typ(*sizeof(<type>). Has unsigned int type (ISO 6.5.3.4). This is not - turned into a constant because some transformations might want to - change types*)
-| -SizeOfE of exp(*sizeof(<expression>)*)
-| -SizeOfStr of string(*sizeof(string_literal). We separate this case out because this is the - only instance in which a string literal should not be treated as - having type pointer to character.*)
-| -AlignOf of typ(*This corresponds to the GCC __alignof_. Has unsigned int type*)
-| -AlignOfE of exp
-| -UnOp of unop * exp * typ(*Unary operation. Includes the type of the result.*)
-| -BinOp of binop * exp * exp * typ(*Binary operation. Includes the type of the result. The arithmetic - conversions are made explicit for the arguments.*)
-| -CastE of typ * exp(*Use Cil.mkCast to make casts.*)
-| -AddrOf of lval(*Always use Cil.mkAddrOf to construct one of these. Apply to an - lvalue of type T yields an expression of type TPtr(T)*)
-| -StartOf of lval(*Conversion from an array to a pointer to the beginning of the array. - Given an lval of type TArray(T) produces an expression of type - TPtr(T). In C this operation is implicit, the StartOf operator is - not printed. We have it in CIL because it makes the typing rules - simpler.*)
- -

-Expressions (Side-effect free)
-
- -
-Constants.
-
type constant = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -CInt64 of int64 * ikind * string option(*Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the - textual representation, if available. (This allows us to print a - constant as, for example, 0xF instead of 15.) Use Cil.integer or - Cil.kinteger to create these. Watch out for integers that cannot be - represented on 64 bits. OCAML does not give Overflow exceptions.*)
-| -CStr of string
-| -CWStr of int64 list
-| -CChr of char(*Character constant. This has type int, so use charConstToInt - to read the value in case sign-extension is needed.*)
-| -CReal of float * fkind * string option(*Floating point constant. Give the fkind (see ISO 6.4.4.2) and also - the textual representation, if available.*)
-| -CEnum of exp * string * enuminfo(*An enumeration constant with the given value, name, from the given - enuminfo. This is used only if Cil.lowerConstants is true - (default). Use Cil.constFoldVisitor to replace these with integer - constants.*)
- -
-Literal constants
-
- -
type unop = - - - - - - - - - - - - - - -
-| -Neg(*Unary minus*)
-| -BNot(*Bitwise complement (~)*)
-| -LNot(*Logical Not (!)*)
- -
-Unary operators
-
- -
type binop = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -PlusA(*arithmetic +*)
-| -PlusPI(*pointer + integer*)
-| -IndexPI(*pointer + integer but only when - it arises from an expression - e[i] when e is a pointer and - not an array. This is semantically - the same as PlusPI but CCured uses - this as a hint that the integer is - probably positive.*)
-| -MinusA(*arithmetic -*)
-| -MinusPI(*pointer - integer*)
-| -MinusPP(*pointer - pointer*)
-| -Mult
-| -Div(*/*)
-| -Mod(*%*)
-| -Shiftlt(*shift left*)
-| -Shiftrt(*shift right*)
-| -Lt(*< (arithmetic comparison)*)
-| -Gt(*> (arithmetic comparison)*)
-| -Le(*<= (arithmetic comparison)*)
-| -Ge(*> (arithmetic comparison)*)
-| -Eq(*== (arithmetic comparison)*)
-| -Ne(*!= (arithmetic comparison)*)
-| -BAnd(*bitwise and*)
-| -BXor(*exclusive-or*)
-| -BOr(*inclusive-or*)
-| -LAnd(*logical and. Unlike other - expressions this one does not - always evaluate both operands. If - you want to use these, you must - set Cil.useLogicalOperators.*)
-| -LOr(*logical or. Unlike other - expressions this one does not - always evaluate both operands. If - you want to use these, you must - set Cil.useLogicalOperators.*)
- -
-Binary operations
-
- -
-Lvalues. Lvalues are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator. -In C the syntax for lvalues is not always a good indication of the meaning -of the lvalue. For example the C value -
 
-a[0][1][2]
-
- might involve 1, 2 or 3 memory reads when used in an expression context, -depending on the declared type of the variable a. If a has type int -[4][4][4] then we have one memory read from somewhere inside the area -that stores the array a. On the other hand if a has type int *** then -the expression really means * ( * ( * (a + 0) + 1) + 2), in which case it is -clear that it involves three separate memory operations. -

- -An lvalue denotes the contents of a range of memory addresses. This range -is denoted as a host object along with an offset within the object. The -host object can be of two kinds: a local or global variable, or an object -whose address is in a pointer expression. We distinguish the two cases so -that we can tell quickly whether we are accessing some component of a -variable directly or we are accessing a memory location through a pointer. -To make it easy to -tell what an lvalue means CIL represents lvalues as a host object and an -offset (see Cil.lval). The host object (represented as -Cil.lhost) can be a local or global variable or can be the object -pointed-to by a pointer expression. The offset (represented as -Cil.offset) is a sequence of field or array index designators. -

- - Both the typing rules and the meaning of an lvalue is very precisely -specified in CIL. -

- - The following are a few useful function for operating on lvalues:

- -The following equivalences hold 
-Mem(AddrOf(Mem a, aoff)), off   = Mem a, aoff + off 
-Mem(AddrOf(Var v, aoff)), off   = Var v, aoff + off 
-AddrOf (Mem a, NoOffset)        = a                 
-

-
type lval = lhost * offset
-
-An lvalue
-
- -
type lhost = - - - - - - - - - -
-| -Var of varinfo(*The host is a variable.*)
-| -Mem of exp(*The host is an object of type T when the expression has pointer - TPtr(T).*)
- -
-The host part of an Cil.lval.
-
- -
type offset = - - - - - - - - - - - - - - -
-| -NoOffset(*No offset. Can be applied to any lvalue and does - not change either the starting address or the type. - This is used when the lval consists of just a host - or as a terminator in a list of other kinds of - offsets.*)
-| -Field of fieldinfo * offset(*A field offset. Can be applied only to an lvalue - that denotes a structure or a union that contains - the mentioned field. This advances the offset to the - beginning of the mentioned field and changes the - type to the type of the mentioned field.*)
-| -Index of exp * offset(*An array index offset. Can be applied only to an - lvalue that denotes an array. This advances the - starting address of the lval to the beginning of the - mentioned array element and changes the denoted type - to be the type of the array element*)
- -
-The offset part of an Cil.lval. Each offset can be applied to certain - kinds of lvalues and its effect is that it advances the starting address - of the lvalue and changes the denoted type, essentially focusing to some - smaller lvalue that is contained in the original one.
-
- -
-Initializers. -A special kind of expressions are those that can appear as initializers for -global variables (initialization of local variables is turned into -assignments). The initializers are represented as type Cil.init. You -can create initializers with Cil.makeZeroInit and you can conveniently -scan compound initializers them with Cil.foldLeftCompound or with Cil.foldLeftCompoundAll.
-
type init = - - - - - - - - - -
-| -SingleInit of exp(*A single initializer*)
-| -CompoundInit of typ * (offset * init) list(*Used only for initializers of structures, unions and arrays. The - offsets are all of the form Field(f, NoOffset) or Index(i, - NoOffset) and specify the field or the index being initialized. For - structures all fields must have an initializer (except the unnamed - bitfields), in the proper order. This is necessary since the offsets - are not printed. For unions there must be exactly one initializer. If - the initializer is not for the first field then a field designator is - printed, so you better be on GCC since MSVC does not understand this. - For arrays, however, we allow you to give only a prefix of the - initializers. You can scan an initializer list with - Cil.foldLeftCompound or with Cil.foldLeftCompoundAll.*)
- -
-Initializers for global variables.
-
- -
type initinfo = { - - - - -
-   -mutable init : init option;
-} - -
-We want to be able to update an initializer in a global variable, so we - define it as a mutable field
-
- -
-Function definitions. -A function definition is always introduced with a GFun constructor at the -top level. All the information about the function is stored into a -Cil.fundec. Some of the information (e.g. its name, type, -storage, attributes) is stored as a Cil.varinfo that is a field of the -fundec. To refer to the function from the expression language you must use -the varinfo. -

- - The function definition contains, in addition to the body, a list of all the -local variables and separately a list of the formals. Both kind of variables -can be referred to in the body of the function. The formals must also be shared -with the formals that appear in the function type. For that reason, to -manipulate formals you should use the provided functions -Cil.makeFormalVar and Cil.setFormals and Cil.makeFormalVar.
-
type fundec = { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-   -mutable svar : varinfo;(*Holds the name and type as a variable, so we can refer to it - easily from the program. All references to this function either - in a function call or in a prototype must point to the same - varinfo.*)
-   -mutable sformals : varinfo list;(*Formals. These must be in the same order and with the same - information as the formal information in the type of the function. - Use Cil.setFormals or - Cil.setFunctionType or Cil.makeFormalVar - to set these formals and ensure that they - are reflected in the function type. Do not make copies of these - because the body refers to them.*)
-   -mutable slocals : varinfo list;(*Locals. Does NOT include the sformals. Do not make copies of - these because the body refers to them.*)
-   -mutable smaxid : int;(*Max local id. Starts at 0. Used for - creating the names of new temporary - variables. Updated by - Cil.makeLocalVar and - Cil.makeTempVar. You can also use - Cil.setMaxId to set it after you - have added the formals and locals.*)
-   -mutable sbody : block;(*The function body.*)
-   -mutable smaxstmtid : int option;(*max id of a (reachable) statement - in this function, if we have - computed it. range = 0 ... - (smaxstmtid-1). This is computed by - Cil.computeCFGInfo.*)
-   -mutable sallstmts : stmt list;(*After you call Cil.computeCFGInfo - this field is set to contain all - statements in the function*)
-} - -

-Function definitions.
-
- -
type block = { - - - - - - - - - -
-   -mutable battrs : attributes;(*Attributes for the block*)
-   -mutable bstmts : stmt list;(*The statements comprising the block*)
-} - -
-A block is a sequence of statements with the control falling through from - one element to the next
-
- -
-Statements. -CIL statements are the structural elements that make the CFG. They are -represented using the type Cil.stmt. Every -statement has a (possibly empty) list of labels. The -Cil.stmtkind field of a statement indicates what kind of statement it -is. -

- - Use Cil.mkStmt to make a statement and the fill-in the fields. -

- -CIL also comes with support for control-flow graphs. The sid field in -stmt can be used to give unique numbers to statements, and the succs -and preds fields can be used to maintain a list of successors and -predecessors for every statement. The CFG information is not computed by -default. Instead you must explicitly use the functions -Cil.prepareCFG and Cil.computeCFGInfo to do it.
-
type stmt = { - - - - - - - - - - - - - - - - - - - - - - - - -
-   -mutable labels : label list;(*Whether the statement starts with some labels, case statements or - default statements.*)
-   -mutable skind : stmtkind;(*The kind of statement*)
-   -mutable sid : int;(*A number (>= 0) that is unique in a function. Filled in only after - the CFG is computed.*)
-   -mutable succs : stmt list;(*The successor statements. They can always be computed from the skind - and the context in which this statement appears. Filled in only after - the CFG is computed.*)
-   -mutable preds : stmt list;(*The inverse of the succs function.*)
-} - -

-Statements.
-
- -
type label = - - - - - - - - - - - - - - -
-| -Label of string * location * bool(*A real label. If the bool is "true", the label is from the - input source program. If the bool is "false", the label was - created by CIL or some other transformation*)
-| -Case of exp * location(*A case statement. This expression - is lowered into a constant if - Cil.lowerConstants is set to - true.*)
-| -Default of location(*A default statement*)
- -
-Labels
-
- -
type stmtkind = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -Instr of instr list(*A group of instructions that do not contain control flow. Control - implicitly falls through.*)
-| -Return of exp option * location(*The return statement. This is a leaf in the CFG.*)
-| -Goto of stmt Pervasives.ref * location(*A goto statement. Appears from actual goto's in the code or from - goto's that have been inserted during elaboration. The reference - points to the statement that is the target of the Goto. This means that - you have to update the reference whenever you replace the target - statement. The target statement MUST have at least a label.*)
-| -Break of location(*A break to the end of the nearest enclosing Loop or Switch*)
-| -Continue of location(*A continue to the start of the nearest enclosing Loop*)
-| -If of exp * block * block * location(*A conditional. Two successors, the "then" and the "else" branches. - Both branches fall-through to the successor of the If statement.*)
-| -Switch of exp * block * stmt list * location(*A switch statement. The statements that implement the cases can be - reached through the provided list. For each such target you can find - among its labels what cases it implements. The statements that - implement the cases are somewhere within the provided block.*)
-| -Loop of block * location * stmt option * stmt option(*A while(1) loop. The termination test is implemented in the body of - a loop using a Break statement. If prepareCFG has been called, - the first stmt option will point to the stmt containing the continue - label for this loop and the second will point to the stmt containing - the break label for this loop.*)
-| -Block of block(*Just a block of statements. Use it as a way to keep some block - attributes local*)
-| -TryFinally of block * block * location
-| -TryExcept of block * (instr list * exp) * block * location
- -
-The various kinds of control-flow statements statements
-
- -
-Instructions. - An instruction Cil.instr is a statement that has no local -(intraprocedural) control flow. It can be either an assignment, -function call, or an inline assembly instruction.
-
type instr = - - - - - - - - - - - - - - -
-| -Set of lval * exp * location(*An assignment. The type of the expression is guaranteed to be the same - with that of the lvalue*)
-| -Call of lval option * exp * exp list * location(*A function call with the (optional) result placed in an lval. It is - possible that the returned type of the function is not identical to - that of the lvalue. In that case a cast is printed. The type of the - actual arguments are identical to those of the declared formals. The - number of arguments is the same as that of the declared formals, except - for vararg functions. This construct is also used to encode a call to - "__builtin_va_arg". In this case the second argument (which should be a - type T) is encoded SizeOf(T)*)
-| -Asm of attributes * string list * (string * lval) list
* (string * exp) list * string list * location		(*There are for storing inline assembly. They follow the GCC - specification: -
-  asm [volatile] ("...template..." "..template.."
-                  : "c1" (o1), "c2" (o2), ..., "cN" (oN)
-                  : "d1" (i1), "d2" (i2), ..., "dM" (iM)
-                  : "r1", "r2", ..., "nL" );
-
-

- -where the parts are -

-

    -
  • volatile (optional): when present, the assembler instruction - cannot be removed, moved, or otherwise optimized
    • -
  • template: a sequence of strings, with %0, %1, %2, etc. in the string to - refer to the input and output expressions. I think they're numbered - consecutively, but the docs don't specify. Each string is printed on - a separate line. This is the only part that is present for MSVC inline - assembly.
    • -
  • "ci" (oi): pairs of constraint-string and output-lval; the - constraint specifies that the register used must have some - property, like being a floating-point register; the constraint - string for outputs also has "=" to indicate it is written, or - "+" to indicate it is both read and written; 'oi' is the - name of a C lvalue (probably a variable name) to be used as - the output destination
    • -
  • "dj" (ij): pairs of constraint and input expression; the constraint - is similar to the "ci"s. the 'ij' is an arbitrary C expression - to be loaded into the corresponding register
    • -
  • "rk": registers to be regarded as "clobbered" by the instruction; - "memory" may be specified for arbitrary memory effects
    • -
- -an example (from gcc manual): -
-  asm volatile ("movc3 %0,%1,%2"
-                : /* no outputs */
-                : "g" (from), "g" (to), "g" (count)
-                : "r0", "r1", "r2", "r3", "r4", "r5");
-
*)
- -
-Instructions.
-
- -
type location = { - - - - - - - - - - - - - - -
-   -line : int;(*The line number. -1 means "do not know"*)
-   -file : string;(*The name of the source file*)
-   -byte : int;(*The byte position in the source file*)
-} - -
-Describes a location in a source file.
-
- -
type typsig = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -TSArray of typsig * int64 option * attribute list
-| -TSPtr of typsig * attribute list
-| -TSComp of bool * string * attribute list
-| -TSFun of typsig * typsig list * bool * attribute list
-| -TSEnum of string * attribute list
-| -TSBase of typ
- -
-Type signatures. Two types are identical iff they have identical - signatures. These contain the same information as types but canonicalized. - For example, two function types that are identical except for the name of - the formal arguments are given the same signature. Also, TNamed - constructors are unrolled.
-
- -
-Lowering Options
-
val lowerConstants : bool Pervasives.ref
-Do lower constants (default true)
-
-
val insertImplicitCasts : bool Pervasives.ref
-Do insert implicit casts (default true)
-
-
type featureDescr = { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-   -fd_enabled : bool Pervasives.ref;(*The enable flag. Set to default value*)
-   -fd_name : string;(*This is used to construct an option "--doxxx" and "--dontxxx" that - enable and disable the feature*)
-   -fd_description : string;
-   -fd_extraopt : (string * Arg.spec * string) list;(*Additional command line options*)
-   -fd_doit : file -> unit;(*This performs the transformation*)
-   -fd_post_check : bool;
-} - -
-To be able to add/remove features easily, each feature should be package - as an interface with the following interface. These features should be
-
- -
val compareLoc : location -> location -> int
-Comparison function for locations. -* Compares first by filename, then line, then byte
-
-
-Values for manipulating globals
-
val emptyFunction : string -> fundec
-Make an empty function
-
-
val setFormals : fundec -> varinfo list -> unit
-Update the formals of a fundec and make sure that the function type - has the same information. Will copy the name as well into the type.
-
-
val setFunctionType : fundec -> typ -> unit
-Set the types of arguments and results as given by the function type - passed as the second argument. Will not copy the names from the function - type to the formals
-
-
val setFunctionTypeMakeFormals : fundec -> typ -> unit
-Set the type of the function and make formal arguments for them
-
-
val setMaxId : fundec -> unit
-Update the smaxid after you have populated with locals and formals - (unless you constructed those using Cil.makeLocalVar or - Cil.makeTempVar.
-
-
val dummyFunDec : fundec
-A dummy function declaration handy when you need one as a placeholder. It - contains inside a dummy varinfo.
-
-
val dummyFile : file
-A dummy file
-
-
val saveBinaryFile : file -> string -> unit
-Write a Cil.file in binary form to the filesystem. The file can be - read back in later using Cil.loadBinaryFile, possibly saving parsing - time. The second argument is the name of the file that should be - created.
-
-
val saveBinaryFileChannel : file -> Pervasives.out_channel -> unit
-Write a Cil.file in binary form to the filesystem. The file can be - read back in later using Cil.loadBinaryFile, possibly saving parsing - time. Does not close the channel.
-
-
val loadBinaryFile : string -> file
-Read a Cil.file in binary form from the filesystem. The first - argument is the name of a file previously created by - Cil.saveBinaryFile.
-
-
val getGlobInit : ?main_name:string -> file -> fundec
-Get the global initializer and create one if it does not already exist. - When it creates a global initializer it attempts to place a call to it in - the main function named by the optional argument (default "main")
-
-
val iterGlobals : file -> (global -> unit) -> unit
-Iterate over all globals, including the global initializer
-
-
val foldGlobals : file -> ('a -> global -> 'a) -> 'a -> 'a
-Fold over all globals, including the global initializer
-
-
val mapGlobals : file -> (global -> global) -> unit
-Map over all globals, including the global initializer and change things - in place
-
-
val new_sid : unit -> int
val prepareCFG : fundec -> unit
-Prepare a function for CFG information computation by - Cil.computeCFGInfo. This function converts all Break, Switch, - Default and Continue Cil.stmtkinds and Cil.labels into Ifs - and Gotos, giving the function body a very CFG-like character. This - function modifies its argument in place.
-
-
val computeCFGInfo : fundec -> bool -> unit
-Compute the CFG information for all statements in a fundec and return a - list of the statements. The input fundec cannot have Break, Switch, - Default, or Continue Cil.stmtkinds or Cil.labels. Use - Cil.prepareCFG to transform them away. The second argument should - be true if you wish a global statement number, false if you wish a - local (per-function) statement numbering. The list of statements is set - in the sallstmts field of a fundec. -

- - NOTE: unless you want the simpler control-flow graph provided by - prepareCFG, or you need the function's smaxstmtid and sallstmt fields - filled in, we recommend you use Cfg.computeFileCFG instead of this - function to compute control-flow information. - Cfg.computeFileCFG is newer and will handle switch, break, and - continue correctly.
-

-
val copyFunction : fundec -> string -> fundec
-Create a deep copy of a function. There should be no sharing between the - copy and the original function
-
-
val pushGlobal : global ->
       types:global list Pervasives.ref ->
       variables:global list Pervasives.ref -> unit
-CIL keeps the types at the beginning of the file and the variables at the - end of the file. This function will take a global and add it to the - corresponding stack. Its operation is actually more complicated because if - the global declares a type that contains references to variables (e.g. in - sizeof in an array length) then it will also add declarations for the - variables to the types stack
-
-
val invalidStmt : stmt
-An empty statement. Used in pretty printing
-
-
val gccBuiltins : (string, typ * typ list * bool) Hashtbl.t
-A list of the GCC built-in functions. Maps the name to the result and - argument types, and whether it is vararg
-
-
val msvcBuiltins : (string, typ * typ list * bool) Hashtbl.t
-A list of the MSVC built-in functions. Maps the name to the result and - argument types, and whether it is vararg
-
-
-Values for manipulating initializers
-
val makeZeroInit : typ -> init
-Make a initializer for zero-ing a data type
-
-
val foldLeftCompound : doinit:(offset -> init -> typ -> 'a -> 'a) ->
       ct:typ -> initl:(offset * init) list -> acc:'a -> 'a
-Fold over the list of initializers in a Compound. doinit is called on - every present initializer, even if it is of compound type. In the case of - arrays there might be missing zero-initializers at the end of the list. - These are not scanned. This is much like List.fold_left except we also - pass the type of the initializer
-
-
val foldLeftCompoundAll : doinit:(offset -> init -> typ -> 'a -> 'a) ->
       ct:typ -> initl:(offset * init) list -> acc:'a -> 'a
-Fold over the list of initializers in a Compound, like - Cil.foldLeftCompound but in the case of an array it scans even missing - zero initializers at the end of the array
-
-
-Values for manipulating types
-
val voidType : typ
-void
-
-
val isVoidType : typ -> bool
val isVoidPtrType : typ -> bool
val intType : typ
-int
-
-
val uintType : typ
-unsigned int
-
-
val longType : typ
-long
-
-
val ulongType : typ
-unsigned long
-
-
val charType : typ
-char
-
-
val charPtrType : typ
-char *
-
-
val wcharKind : ikind Pervasives.ref
-wchar_t (depends on architecture) and is set when you call - Cil.initCIL.
-
-
val wcharType : typ Pervasives.ref
val charConstPtrType : typ
-char const *
-
-
val voidPtrType : typ
-void *
-
-
val intPtrType : typ
-int *
-
-
val uintPtrType : typ
-unsigned int *
-
-
val doubleType : typ
-double
-
-
val upointType : typ Pervasives.ref
val typeOfSizeOf : typ Pervasives.ref
val isSigned : ikind -> bool
-Returns true if and only if the given integer type is signed.
-
-
val mkCompInfo : bool ->
       string ->
       (compinfo ->
        (string * typ * int option * attributes * location) list) ->
       attributes -> compinfo
-Creates a a (potentially recursive) composite type. The arguments are: - (1) a boolean indicating whether it is a struct or a union, (2) the name - (always non-empty), (3) a function that when given a representation of the - structure type constructs the type of the fields recursive type (the first - argument is only useful when some fields need to refer to the type of the - structure itself), and (4) a list of attributes to be associated with the - composite type. The resulting compinfo has the field "cdefined" only if - the list of fields is non-empty.
-
-
val copyCompInfo : compinfo -> string -> compinfo
-Makes a shallow copy of a Cil.compinfo changing the name and the key.
-
-
val missingFieldName : string
-This is a constant used as the name of an unnamed bitfield. These fields - do not participate in initialization and their name is not printed.
-
-
val compFullName : compinfo -> string
-Get the full name of a comp
-
-
val isCompleteType : typ -> bool
-Returns true if this is a complete type. - This means that sizeof(t) makes sense. - Incomplete types are not yet defined - structures and empty arrays.
-
-
val unrollType : typ -> typ
-Unroll a type until it exposes a non - TNamed. Will collect all attributes appearing in TNamed!!!
-
-
val unrollTypeDeep : typ -> typ
-Unroll all the TNamed in a type (even under type constructors such as - TPtr, TFun or TArray. Does not unroll the types of fields in TComp - types. Will collect all attributes
-
-
val separateStorageModifiers : attribute list -> attribute list * attribute list
-Separate out the storage-modifier name attributes
-
-
val isIntegralType : typ -> bool
-True if the argument is an integral type (i.e. integer or enum)
-
-
val isArithmeticType : typ -> bool
-True if the argument is an arithmetic type (i.e. integer, enum or - floating point
-
-
val isPointerType : typ -> bool
-True if the argument is a pointer type
-
-
val isFunctionType : typ -> bool
-True if the argument is a function type
-
-
val argsToList : (string * typ * attributes) list option ->
       (string * typ * attributes) list
-Obtain the argument list ([] if None)
-
-
val isArrayType : typ -> bool
-True if the argument is an array type
-
-
exception LenOfArray
-
-Raised when Cil.lenOfArray fails either because the length is None - or because it is a non-constant expression
-
-
val lenOfArray : exp option -> int
-Call to compute the array length as present in the array type, to an - integer. Raises Cil.LenOfArray if not able to compute the length, such - as when there is no length or the length is not a constant.
-
-
val getCompField : compinfo -> string -> fieldinfo
-Return a named fieldinfo in compinfo, or raise Not_found
-
-
type existsAction = - - - - - - - - - - - - - - -
-| -ExistsTrue
-| -ExistsFalse
-| -ExistsMaybe
- -
-A datatype to be used in conjunction with existsType
-
- -
val existsType : (typ -> existsAction) -> typ -> bool
-Scans a type by applying the function on all elements. - When the function returns ExistsTrue, the scan stops with - true. When the function returns ExistsFalse then the current branch is not - scanned anymore. Care is taken to - apply the function only once on each composite type, thus avoiding - circularity. When the function returns ExistsMaybe then the types that - construct the current type are scanned (e.g. the base type for TPtr and - TArray, the type of fields for a TComp, etc).
-
-
val splitFunctionType : typ ->
       typ * (string * typ * attributes) list option * bool *
       attributes
-Given a function type split it into return type, - arguments, is_vararg and attributes. An error is raised if the type is not - a function type -

-Same as Cil.splitFunctionType but takes a varinfo. Prints a nicer - error message if the varinfo is not for a function
-

-
val splitFunctionTypeVI : varinfo ->
       typ * (string * typ * attributes) list option * bool *
       attributes

-Type signatures
-
-Type signatures. Two types are identical iff they have identical - signatures. These contain the same information as types but canonicalized. - For example, two function types that are identical except for the name of - the formal arguments are given the same signature. Also, TNamed - constructors are unrolled. You shoud use Util.equals to compare type - signatures because they might still contain circular structures (through - attributes, and sizeof)
-
val d_typsig : unit -> typsig -> Pretty.doc
-Print a type signature
-
-
val typeSig : typ -> typsig
-Compute a type signature
-
-
val typeSigWithAttrs : ?ignoreSign:bool ->
       (attributes -> attributes) -> typ -> typsig
-Like Cil.typeSig but customize the incorporation of attributes. - Use ~ignoreSign:true to convert all signed integer types to unsigned, - so that signed and unsigned will compare the same.
-
-
val setTypeSigAttrs : attributes -> typsig -> typsig
-Replace the attributes of a signature (only at top level)
-
-
val typeSigAttrs : typsig -> attributes
-Get the top-level attributes of a signature
-
-
-LVALUES
-
val makeVarinfo : bool -> string -> typ -> varinfo
-Make a varinfo. Use this (rarely) to make a raw varinfo. Use other - functions to make locals (Cil.makeLocalVar or Cil.makeFormalVar or - Cil.makeTempVar) and globals (Cil.makeGlobalVar). Note that this - function will assign a new identifier. The first argument specifies - whether the varinfo is for a global.
-
-
val makeFormalVar : fundec -> ?where:string -> string -> typ -> varinfo
-Make a formal variable for a function. Insert it in both the sformals - and the type of the function. You can optionally specify where to insert - this one. If where = "^" then it is inserted first. If where = "$" then - it is inserted last. Otherwise where must be the name of a formal after - which to insert this. By default it is inserted at the end.
-
-
val makeLocalVar : fundec -> ?insert:bool -> string -> typ -> varinfo
-Make a local variable and add it to a function's slocals (only if insert = - true, which is the default). Make sure you know what you are doing if you - set insert=false.
-
-
val makeTempVar : fundec -> ?name:string -> typ -> varinfo
-Make a temporary variable and add it to a function's slocals. The name of - the temporary variable will be generated based on the given name hint so - that to avoid conflicts with other locals.
-
-
val makeGlobalVar : string -> typ -> varinfo
-Make a global variable. Your responsibility to make sure that the name - is unique
-
-
val copyVarinfo : varinfo -> string -> varinfo
-Make a shallow copy of a varinfo and assign a new identifier
-
-
val newVID : unit -> int
-Generate a new variable ID. This will be different than any variable ID - that is generated by Cil.makeLocalVar and friends
-
-
val addOffsetLval : offset -> lval -> lval
-Add an offset at the end of an lvalue. Make sure the type of the lvalue - and the offset are compatible.
-
-
val addOffset : offset -> offset -> offset
-addOffset o1 o2 adds o1 to the end of o2.
-
-
val removeOffsetLval : lval -> lval * offset
-Remove ONE offset from the end of an lvalue. Returns the lvalue with the - trimmed offset and the final offset. If the final offset is NoOffset - then the original lval did not have an offset.
-
-
val removeOffset : offset -> offset * offset
-Remove ONE offset from the end of an offset sequence. Returns the - trimmed offset and the final offset. If the final offset is NoOffset - then the original lval did not have an offset.
-
-
val typeOfLval : lval -> typ
-Compute the type of an lvalue
-
-
val typeOffset : typ -> offset -> typ
-Compute the type of an offset from a base type
-
-
-Values for manipulating expressions
-
val zero : exp
-0
-
-
val one : exp
-1
-
-
val mone : exp
--1
-
-
val kinteger64 : ikind -> int64 -> exp
-Construct an integer of a given kind, using OCaml's int64 type. If needed - it will truncate the integer to be within the representable range for the - given kind.
-
-
val kinteger : ikind -> int -> exp
-Construct an integer of a given kind. Converts the integer to int64 and - then uses kinteger64. This might truncate the value if you use a kind - that cannot represent the given integer. This can only happen for one of - the Char or Short kinds
-
-
val integer : int -> exp
-Construct an integer of kind IInt. You can use this always since the - OCaml integers are 31 bits and are guaranteed to fit in an IInt
-
-
val isInteger : exp -> int64 option
-True if the given expression is a (possibly cast'ed) - character or an integer constant
-
-
val isConstant : exp -> bool
-True if the expression is a compile-time constant
-
-
val isZero : exp -> bool
-True if the given expression is a (possibly cast'ed) integer or character - constant with value zero
-
-
val charConstToInt : char -> constant
-Given the character c in a (CChr c), sign-extend it to 32 bits. - (This is the official way of interpreting character constants, according to - ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) - Returns CInt64(sign-extened c, IInt, None)
-
-
val constFold : bool -> exp -> exp
-Do constant folding on an expression. If the first argument is true then - will also compute compiler-dependent expressions such as sizeof
-
-
val constFoldBinOp : bool -> binop -> exp -> exp -> typ -> exp
-Do constant folding on a binary operation. The bulk of the work done by - constFold is done here. If the first argument is true then - will also compute compiler-dependent expressions such as sizeof
-
-
val increm : exp -> int -> exp
-Increment an expression. Can be arithmetic or pointer type
-
-
val var : varinfo -> lval
-Makes an lvalue out of a given variable
-
-
val mkAddrOf : lval -> exp
-Make an AddrOf. Given an lvalue of type T will give back an expression of - type ptr(T). It optimizes somewhat expressions like "& v" and "& v0"
-
-
val mkAddrOrStartOf : lval -> exp
-Like mkAddrOf except if the type of lval is an array then it uses - StartOf. This is the right operation for getting a pointer to the start - of the storage denoted by lval.
-
-
val mkMem : addr:exp -> off:offset -> lval
-Make a Mem, while optimizing AddrOf. The type of the addr must be - TPtr(t) and the type of the resulting lval is t. Note that in CIL the - implicit conversion between an array and the pointer to the first - element does not apply. You must do the conversion yourself using - StartOf
-
-
val mkString : string -> exp
-Make an expression that is a string constant (of pointer type)
-
-
val mkCastT : e:exp -> oldt:typ -> newt:typ -> exp
-Construct a cast when having the old type of the expression. If the new - type is the same as the old type, then no cast is added.
-
-
val mkCast : e:exp -> newt:typ -> exp
-Like Cil.mkCastT but uses typeOf to get oldt
-
-
val stripCasts : exp -> exp
-Removes casts from this expression, but ignores casts within - other expression constructs. So we delete the (A) and (B) casts from - "(A)(B)(x + (C)y)", but leave the (C) cast.
-
-
val typeOf : exp -> typ
-Compute the type of an expression
-
-
val parseInt : string -> exp
-Convert a string representing a C integer literal to an expression. - Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL
-
-
-Values for manipulating statements
-
val mkStmt : stmtkind -> stmt
-Construct a statement, given its kind. Initialize the sid field to -1, - and labels, succs and preds to the empty list
-
-
val mkBlock : stmt list -> block
-Construct a block with no attributes, given a list of statements
-
-
val mkStmtOneInstr : instr -> stmt
-Construct a statement consisting of just one instruction
-
-
val compactStmts : stmt list -> stmt list
-Try to compress statements so as to get maximal basic blocks
-
-
val mkEmptyStmt : unit -> stmt
-Returns an empty statement (of kind Instr)
-
-
val dummyInstr : instr
-A instr to serve as a placeholder
-
-
val dummyStmt : stmt
-A statement consisting of just dummyInstr
-
-
val mkWhile : guard:exp -> body:stmt list -> stmt list
-Make a while loop. Can contain Break or Continue
-
-
val mkForIncr : iter:varinfo ->
       first:exp ->
       stopat:exp -> incr:exp -> body:stmt list -> stmt list
-Make a for loop for(i=start; i<past; i += incr) { ... }. The body - can contain Break but not Continue. Can be used with i a pointer - or an integer. Start and done must have the same type but incr - must be an integer
-
-
val mkFor : start:stmt list ->
       guard:exp -> next:stmt list -> body:stmt list -> stmt list
-Make a for loop for(start; guard; next) { ... }. The body can - contain Break but not Continue !!!
-
-
-Values for manipulating attributes
-
type attributeClass = - - - - - - - - - - - - - - -
-| -AttrName of bool(*Attribute of a name. If argument is true and we are on MSVC then - the attribute is printed using __declspec as part of the storage - specifier*)
-| -AttrFunType of bool(*Attribute of a function type. If argument is true and we are on - MSVC then the attribute is printed just before the function name*)
-| -AttrType(*Attribute of a type*)
- -
-Various classes of attributes
-
- -
val attributeHash : (string, attributeClass) Hashtbl.t
-This table contains the mapping of predefined attributes to classes. - Extend this table with more attributes as you need. This table is used to - determine how to associate attributes with names or types
-
-
val partitionAttributes : default:attributeClass ->
       attributes ->
       attribute list * attribute list * attribute list
-Partition the attributes into classes:name attributes, function type, - and type attributes
-
-
val addAttribute : attribute -> attributes -> attributes
-Add an attribute. Maintains the attributes in sorted order of the second - argument
-
-
val addAttributes : attribute list -> attributes -> attributes
-Add a list of attributes. Maintains the attributes in sorted order. The - second argument must be sorted, but not necessarily the first
-
-
val dropAttribute : string -> attributes -> attributes
-Remove all attributes with the given name. Maintains the attributes in - sorted order.
-
-
val dropAttributes : string list -> attributes -> attributes
-Remove all attributes with names appearing in the string list. - Maintains the attributes in sorted order
-
-
val filterAttributes : string -> attributes -> attributes
-Retains attributes with the given name
-
-
val hasAttribute : string -> attributes -> bool
-True if the named attribute appears in the attribute list. The list of - attributes must be sorted.
-
-
val typeAttrs : typ -> attribute list
-Returns all the attributes contained in a type. This requires a traversal - of the type structure, in case of composite, enumeration and named types
-
-
val setTypeAttrs : typ -> attributes -> typ
val typeAddAttributes : attribute list -> typ -> typ
-Add some attributes to a type
-
-
val typeRemoveAttributes : string list -> typ -> typ
-Remove all attributes with the given names from a type. Note that this - does not remove attributes from typedef and tag definitions, just from - their uses
-
-
-The visitor
-
type 'a visitAction = - - - - - - - - - - - - - - - - - - - -
-| -SkipChildren(*Do not visit the children. Return - the node as it is.*)
-| -DoChildren(*Continue with the children of this - node. Rebuild the node on return - if any of the children changes - (use == test)*)
-| -ChangeTo of 'a(*Replace the expression with the - given one*)
-| -ChangeDoChildrenPost of 'a * ('a -> 'a)(*First consider that the entire - exp is replaced by the first - parameter. Then continue with - the children. On return rebuild - the node if any of the children - has changed and then apply the - function on the node*)
- -
-Different visiting actions. 'a will be instantiated with exp, instr, - etc.
-
- -
class type cilVisitor = object .. end
-A visitor interface for traversing CIL trees. -
-
class nopCilVisitor : cilVisitor
-Default Visitor. -
-
val visitCilFile : cilVisitor -> file -> unit
-Visit a file. This will will re-cons all globals TWICE (so that it is - tail-recursive). Use Cil.visitCilFileSameGlobals if your visitor will - not change the list of globals.
-
-
val visitCilFileSameGlobals : cilVisitor -> file -> unit
-A visitor for the whole file that does not change the globals (but maybe - changes things inside the globals). Use this function instead of - Cil.visitCilFile whenever appropriate because it is more efficient for - long files.
-
-
val visitCilGlobal : cilVisitor -> global -> global list
-Visit a global
-
-
val visitCilFunction : cilVisitor -> fundec -> fundec
-Visit a function definition
-
-
val visitCilExpr : cilVisitor -> exp -> exp
val visitCilLval : cilVisitor -> lval -> lval
-Visit an lvalue
-
-
val visitCilOffset : cilVisitor -> offset -> offset
-Visit an lvalue or recursive offset
-
-
val visitCilInitOffset : cilVisitor -> offset -> offset
-Visit an initializer offset
-
-
val visitCilInstr : cilVisitor -> instr -> instr list
-Visit an instruction
-
-
val visitCilStmt : cilVisitor -> stmt -> stmt
-Visit a statement
-
-
val visitCilBlock : cilVisitor -> block -> block
-Visit a block
-
-
val visitCilType : cilVisitor -> typ -> typ
-Visit a type
-
-
val visitCilVarDecl : cilVisitor -> varinfo -> varinfo
-Visit a variable declaration
-
-
val visitCilInit : cilVisitor -> init -> init
-Visit an initializer
-
-
val visitCilAttributes : cilVisitor -> attribute list -> attribute list
-Visit a list of attributes
-
-
-Utility functions
-
val msvcMode : bool Pervasives.ref
-Whether the pretty printer should print output for the MS VC compiler. - Default is GCC. After you set this function you should call Cil.initCIL.
-
-
val useLogicalOperators : bool Pervasives.ref
-Whether to use the logical operands LAnd and LOr. By default, do not use - them because they are unlike other expressions and do not evaluate both of - their operands
-
-
val constFoldVisitor : bool -> cilVisitor
-A visitor that does constant folding. Pass as argument whether you want - machine specific simplifications to be done, or not.
-
-
type lineDirectiveStyle = - - - - - - - - - - - - - - -
-| -LineComment
-| -LinePreprocessorInput
-| -LinePreprocessorOutput
- -
-Styles of printing line directives
-
- -
val lineDirectiveStyle : lineDirectiveStyle option Pervasives.ref
-How to print line directives
-
-
val print_CIL_Input : bool Pervasives.ref
-Whether we print something that will only be used as input to our own - parser. In that case we are a bit more liberal in what we print
-
-
val printCilAsIs : bool Pervasives.ref
-Whether to print the CIL as they are, without trying to be smart and - print nicer code. Normally this is false, in which case the pretty - printer will turn the while(1) loops of CIL into nicer loops, will not - print empty "else" blocks, etc. These is one case howewer in which if you - turn this on you will get code that does not compile: if you use varargs - the __builtin_va_arg function will be printed in its internal form.
-
-
val lineLength : int Pervasives.ref
-The length used when wrapping output lines. Setting this variable to - a large integer will prevent wrapping and make #line directives more - accurate.
-
-
val forgcc : string -> string
-Return the string 's' if we're printing output for gcc, suppres - it if we're printing for CIL to parse back in. the purpose is to - hide things from gcc that it complains about, but still be able - to do lossless transformations when CIL is the consumer
-
-
-Debugging support
-
val currentLoc : location Pervasives.ref
-A reference to the current location. If you are careful to set this to - the current location then you can use some built-in logging functions that - will print the location.
-
-
val currentGlobal : global Pervasives.ref
-A reference to the current global being visited
-
-
-CIL has a fairly easy to use mechanism for printing error messages. This - mechanism is built on top of the pretty-printer mechanism (see - Pretty.doc) and the error-message modules (see Errormsg.error). -

- - Here is a typical example for printing a log message: 

-ignore (Errormsg.log "Expression %a is not positive (at %s:%i)\n"
-                        d_exp e loc.file loc.line)
-
-

- - and here is an example of how you print a fatal error message that stop the - execution: 

-Errormsg.s (Errormsg.bug "Why am I here?")
-
-

- - Notice that you can use C format strings with some extension. The most -useful extension is "%a" that means to consumer the next two argument from -the argument list and to apply the first to unit and then to the second -and to print the resulting Pretty.doc. For each major type in CIL there is -a corresponding function that pretty-prints an element of that type:
-

val d_loc : unit -> location -> Pretty.doc
-Pretty-print a location
-
-
val d_thisloc : unit -> Pretty.doc
-Pretty-print the Cil.currentLoc
-
-
val d_ikind : unit -> ikind -> Pretty.doc
-Pretty-print an integer of a given kind
-
-
val d_fkind : unit -> fkind -> Pretty.doc
-Pretty-print a floating-point kind
-
-
val d_storage : unit -> storage -> Pretty.doc
-Pretty-print storage-class information
-
-
val d_const : unit -> constant -> Pretty.doc
-Pretty-print a constant
-
-
val derefStarLevel : int
val indexLevel : int
val arrowLevel : int
val addrOfLevel : int
val additiveLevel : int
val comparativeLevel : int
val bitwiseLevel : int
val getParenthLevel : exp -> int
-Parentheses level. An expression "a op b" is printed parenthesized if its - parentheses level is >= that that of its context. Identifiers have the - lowest level and weakly binding operators (e.g. |) have the largest level. - The correctness criterion is that a smaller level MUST correspond to a - stronger precedence!
-
-
class type cilPrinter = object .. end
-A printer interface for CIL trees. -
-
class defaultCilPrinterClass : cilPrinter
val defaultCilPrinter : cilPrinter
class plainCilPrinterClass : cilPrinter
-These are pretty-printers that will show you more details on the internal - CIL representation, without trying hard to make it look like C -
-
val plainCilPrinter : cilPrinter
val printerForMaincil : cilPrinter Pervasives.ref
val printType : cilPrinter -> unit -> typ -> Pretty.doc
-Print a type given a pretty printer
-
-
val printExp : cilPrinter -> unit -> exp -> Pretty.doc
-Print an expression given a pretty printer
-
-
val printLval : cilPrinter -> unit -> lval -> Pretty.doc
-Print an lvalue given a pretty printer
-
-
val printGlobal : cilPrinter -> unit -> global -> Pretty.doc
-Print a global given a pretty printer
-
-
val printAttr : cilPrinter -> unit -> attribute -> Pretty.doc
-Print an attribute given a pretty printer
-
-
val printAttrs : cilPrinter -> unit -> attributes -> Pretty.doc
-Print a set of attributes given a pretty printer
-
-
val printInstr : cilPrinter -> unit -> instr -> Pretty.doc
-Print an instruction given a pretty printer
-
-
val printStmt : cilPrinter -> unit -> stmt -> Pretty.doc
-Print a statement given a pretty printer. This can take very long - (or even overflow the stack) for huge statements. Use Cil.dumpStmt - instead.
-
-
val printBlock : cilPrinter -> unit -> block -> Pretty.doc
-Print a block given a pretty printer. This can take very long - (or even overflow the stack) for huge block. Use Cil.dumpBlock - instead.
-
-
val dumpStmt : cilPrinter -> Pervasives.out_channel -> int -> stmt -> unit
-Dump a statement to a file using a given indentation. Use this instead of - Cil.printStmt whenever possible.
-
-
val dumpBlock : cilPrinter -> Pervasives.out_channel -> int -> block -> unit
-Dump a block to a file using a given indentation. Use this instead of - Cil.printBlock whenever possible.
-
-
val printInit : cilPrinter -> unit -> init -> Pretty.doc
-Print an initializer given a pretty printer. This can take very long - (or even overflow the stack) for huge initializers. Use Cil.dumpInit - instead.
-
-
val dumpInit : cilPrinter -> Pervasives.out_channel -> int -> init -> unit
-Dump an initializer to a file using a given indentation. Use this instead of - Cil.printInit whenever possible.
-
-
val d_type : unit -> typ -> Pretty.doc
-Pretty-print a type using Cil.defaultCilPrinter
-
-
val d_exp : unit -> exp -> Pretty.doc
-Pretty-print an expression using Cil.defaultCilPrinter
-
-
val d_lval : unit -> lval -> Pretty.doc
-Pretty-print an lvalue using Cil.defaultCilPrinter
-
-
val d_offset : Pretty.doc -> unit -> offset -> Pretty.doc
-Pretty-print an offset using Cil.defaultCilPrinter, given the pretty - printing for the base.
-
-
val d_init : unit -> init -> Pretty.doc
-Pretty-print an initializer using Cil.defaultCilPrinter. This can be - extremely slow (or even overflow the stack) for huge initializers. Use - Cil.dumpInit instead.
-
-
val d_binop : unit -> binop -> Pretty.doc
-Pretty-print a binary operator
-
-
val d_unop : unit -> unop -> Pretty.doc
-Pretty-print a unary operator
-
-
val d_attr : unit -> attribute -> Pretty.doc
-Pretty-print an attribute using Cil.defaultCilPrinter
-
-
val d_attrparam : unit -> attrparam -> Pretty.doc
-Pretty-print an argument of an attribute using Cil.defaultCilPrinter
-
-
val d_attrlist : unit -> attributes -> Pretty.doc
-Pretty-print a list of attributes using Cil.defaultCilPrinter
-
-
val d_instr : unit -> instr -> Pretty.doc
-Pretty-print an instruction using Cil.defaultCilPrinter
-
-
val d_label : unit -> label -> Pretty.doc
-Pretty-print a label using Cil.defaultCilPrinter
-
-
val d_stmt : unit -> stmt -> Pretty.doc
-Pretty-print a statement using Cil.defaultCilPrinter. This can be - extremely slow (or even overflow the stack) for huge statements. Use - Cil.dumpStmt instead.
-
-
val d_block : unit -> block -> Pretty.doc
-Pretty-print a block using Cil.defaultCilPrinter. This can be - extremely slow (or even overflow the stack) for huge blocks. Use - Cil.dumpBlock instead.
-
-
val d_global : unit -> global -> Pretty.doc
-Pretty-print the internal representation of a global using - Cil.defaultCilPrinter. This can be extremely slow (or even overflow the - stack) for huge globals (such as arrays with lots of initializers). Use - Cil.dumpGlobal instead.
-
-
val dn_exp : unit -> exp -> Pretty.doc
-Versions of the above pretty printers, that don't print #line directives
-
-
val dn_lval : unit -> lval -> Pretty.doc
val dn_init : unit -> init -> Pretty.doc
val dn_type : unit -> typ -> Pretty.doc
val dn_global : unit -> global -> Pretty.doc
val dn_attrlist : unit -> attributes -> Pretty.doc
val dn_attr : unit -> attribute -> Pretty.doc
val dn_attrparam : unit -> attrparam -> Pretty.doc
val dn_stmt : unit -> stmt -> Pretty.doc
val dn_instr : unit -> instr -> Pretty.doc
val d_shortglobal : unit -> global -> Pretty.doc
-Pretty-print a short description of the global. This is useful for error - messages
-
-
val dumpGlobal : cilPrinter -> Pervasives.out_channel -> global -> unit
-Pretty-print a global. Here you give the channel where the printout - should be sent.
-
-
val dumpFile : cilPrinter -> Pervasives.out_channel -> string -> file -> unit
-Pretty-print an entire file. Here you give the channel where the printout - should be sent.
-
-
val bug : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.bug except that Cil.currentLoc is also printed
-
-
val unimp : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.unimp except that Cil.currentLocis also printed
-
-
val error : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.error except that Cil.currentLoc is also printed
-
-
val errorLoc : location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Cil.error except that it explicitly takes a location argument, - instead of using the Cil.currentLoc
-
-
val warn : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.warn except that Cil.currentLoc is also printed
-
-
val warnOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.warnOpt except that Cil.currentLoc is also printed. - This warning is printed only of Errormsg.warnFlag is set.
-
-
val warnContext : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.warn except that Cil.currentLoc and context - is also printed
-
-
val warnContextOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Errormsg.warn except that Cil.currentLoc and context is also - printed. This warning is printed only of Errormsg.warnFlag is set.
-
-
val warnLoc : location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
-Like Cil.warn except that it explicitly takes a location argument, - instead of using the Cil.currentLoc
-
-
-Sometimes you do not want to see the syntactic sugar that the above - pretty-printing functions add. In that case you can use the following - pretty-printing functions. But note that the output of these functions is - not valid C
-
val d_plainexp : unit -> exp -> Pretty.doc
-Pretty-print the internal representation of an expression
-
-
val d_plaininit : unit -> init -> Pretty.doc
-Pretty-print the internal representation of an integer
-
-
val d_plainlval : unit -> lval -> Pretty.doc
-Pretty-print the internal representation of an lvalue
-
-
-Pretty-print the internal representation of an lvalue offset -val d_plainoffset: unit -> offset -> Pretty.doc
-
val d_plaintype : unit -> typ -> Pretty.doc
-Pretty-print the internal representation of a type
-
-
-ALPHA conversion has been moved to the Alpha module.
-
val uniqueVarNames : file -> unit
-Assign unique names to local variables. This might be necessary after you - transformed the code and added or renamed some new variables. Names are - not used by CIL internally, but once you print the file out the compiler - downstream might be confused. You might - have added a new global that happens to have the same name as a local in - some function. Rename the local to ensure that there would never be - confusioin. Or, viceversa, you might have added a local with a name that - conflicts with a global
-
-
-Optimization Passes
-
val peepHole2 : (instr * instr -> instr list option) -> stmt list -> unit
-A peephole optimizer that processes two adjacent statements and possibly - replaces them both. If some replacement happens, then the new statements - are themselves subject to optimization
-
-
val peepHole1 : (instr -> instr list option) -> stmt list -> unit
-Similar to peepHole2 except that the optimization window consists of - one statement, not two
-
-
-Machine dependency
-
exception SizeOfError of string * typ
-
-Raised when one of the bitsSizeOf functions cannot compute the size of a - type. This can happen because the type contains array-length expressions - that we don't know how to compute or because it is a type whose size is - not defined (e.g. TFun or an undefined compinfo). The string is an - explanation of the error
-
-
val bitsSizeOf : typ -> int
-The size of a type, in bits. Trailing padding is added for structs and - arrays. Raises Cil.SizeOfError when it cannot compute the size. This - function is architecture dependent, so you should only call this after you - call Cil.initCIL. Remember that on GCC sizeof(void) is 1!
-
-
val sizeOf : typ -> exp
val alignOf_int : typ -> int
-The minimum alignment (in bytes) for a type. This function is - architecture dependent, so you should only call this after you call - Cil.initCIL.
-
-
val bitsOffset : typ -> offset -> int * int
-Give a type of a base and an offset, returns the number of bits from the - base address and the width (also expressed in bits) for the subobject - denoted by the offset. Raises Cil.SizeOfError when it cannot compute - the size. This function is architecture dependent, so you should only call - this after you call Cil.initCIL.
-
-
val char_is_unsigned : bool Pervasives.ref
-Whether "char" is unsigned. Set after you call Cil.initCIL
-
-
val little_endian : bool Pervasives.ref
-Whether the machine is little endian. Set after you call Cil.initCIL
-
-
val underscore_name : bool Pervasives.ref
-Whether the compiler generates assembly labels by prepending "_" to the - identifier. That is, will function foo() have the label "foo", or "_foo"? - Set after you call Cil.initCIL
-
-
val locUnknown : location
-Represents a location that cannot be determined
-
-
val get_instrLoc : instr -> location
-Return the location of an instruction
-
-
val get_globalLoc : global -> location
-Return the location of a global, or locUnknown
-
-
val get_stmtLoc : stmtkind -> location
-Return the location of a statement, or locUnknown
-
-
val dExp : Pretty.doc -> exp
-Generate an Cil.exp to be used in case of errors.
-
-
val dInstr : Pretty.doc -> location -> instr
-Generate an Cil.instr to be used in case of errors.
-
-
val dGlobal : Pretty.doc -> location -> global
-Generate a Cil.global to be used in case of errors.
-
-
val mapNoCopy : ('a -> 'a) -> 'a list -> 'a list
-Like map but try not to make a copy of the list
-
-
val mapNoCopyList : ('a -> 'a list) -> 'a list -> 'a list
-Like map but each call can return a list. Try not to make a copy of the - list
-
-
val startsWith : string -> string -> bool
-sm: return true if the first is a prefix of the second string
-
-
-An Interpreter for constructing CIL constructs
-
type formatArg = - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-| -Fe of exp
-| -Feo of exp option(*For array lengths*)
-| -Fu of unop
-| -Fb of binop
-| -Fk of ikind
-| -FE of exp list(*For arguments in a function call*)
-| -Ff of (string * typ * attributes)(*For a formal argument*)
-| -FF of (string * typ * attributes) list(*For formal argument lists*)
-| -Fva of bool(*For the ellipsis in a function type*)
-| -Fv of varinfo
-| -Fl of lval
-| -Flo of lval option
-| -Fo of offset
-| -Fc of compinfo
-| -Fi of instr
-| -FI of instr list
-| -Ft of typ
-| -Fd of int
-| -Fg of string
-| -Fs of stmt
-| -FS of stmt list
-| -FA of attributes
-| -Fp of attrparam
-| -FP of attrparam list
-| -FX of string
- -
-The type of argument for the interpreter
-
- -
val d_formatarg : unit -> formatArg -> Pretty.doc
-Pretty-prints a format arg
-
-
val lowerConstants : bool Pervasives.ref
-Do lower constant expressions into constants (default true)
-
- \ No newline at end of file diff --git a/cil/doc/api/Cil.nopCilVisitor.html b/cil/doc/api/Cil.nopCilVisitor.html deleted file mode 100644 index 868e79d..0000000 --- a/cil/doc/api/Cil.nopCilVisitor.html +++ /dev/null @@ -1,35 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.nopCilVisitor - - -
 Up - Next -
-

Class Cil.nopCilVisitor

-
-
class nopCilVisitor : cilVisitor
Default Visitor. Traverses the CIL tree without modifying anything
-
- \ No newline at end of file diff --git a/cil/doc/api/Cil.plainCilPrinterClass.html b/cil/doc/api/Cil.plainCilPrinterClass.html deleted file mode 100644 index 0d5fca5..0000000 --- a/cil/doc/api/Cil.plainCilPrinterClass.html +++ /dev/null @@ -1,36 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.plainCilPrinterClass - - -
Previous - Up - 
-

Class Cil.plainCilPrinterClass

-
-
class plainCilPrinterClass : cilPrinter
These are pretty-printers that will show you more details on the internal - CIL representation, without trying hard to make it look like C
-
- \ No newline at end of file diff --git a/cil/doc/api/Cillower.html b/cil/doc/api/Cillower.html deleted file mode 100644 index d8fa8dd..0000000 --- a/cil/doc/api/Cillower.html +++ /dev/null @@ -1,40 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cillower - - -
Previous - Up - Next -
-

Module Cillower

-
-
module Cillower: sig .. end
A number of lowering passes over CIL
-
-
val lowerEnumVisitor : Cil.cilVisitor
-Replace enumeration constants with integer constants
-
- \ No newline at end of file diff --git a/cil/doc/api/Clist.html b/cil/doc/api/Clist.html deleted file mode 100644 index 27f373e..0000000 --- a/cil/doc/api/Clist.html +++ /dev/null @@ -1,118 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Clist - - -
Previous - Up - Next -
-

Module Clist

-
-
module Clist: sig .. end
Utilities for managing "concatenable lists" (clists). We often need to - concatenate sequences, and using lists for this purpose is expensive. This - module provides routines to manage such lists more efficiently. In this - model, we never do cons or append explicitly. Instead we maintain - the elements of the list in a special data structure. Routines are provided - to convert to/from ordinary lists, and carry out common list operations.
-
-
type 'a clist = - - - - - - - - - - - - - - - - - - - -
-| -CList of 'a list(*The only representation for the empty - list. Try to use sparingly.*)
-| -CConsL of 'a * 'a clist(*Do not use this a lot because scanning - it is not tail recursive*)
-| -CConsR of 'a clist * 'a
-| -CSeq of 'a clist * 'a clist(*We concatenate only two of them at this - time. Neither is the empty clist. To be - sure always use append to make these*)
- -
-The clist datatype. A clist can be an ordinary list, or a clist preceded - or followed by an element, or two clists implicitly appended together
-
- -
val toList : 'a clist -> 'a list
-Convert a clist to an ordinary list
-
-
val fromList : 'a list -> 'a clist
-Convert an ordinary list to a clist
-
-
val single : 'a -> 'a clist
-Create a clist containing one element
-
-
val empty : 'a clist
-The empty clist
-
-
val append : 'a clist -> 'a clist -> 'a clist
-Append two clists
-
-
val checkBeforeAppend : 'a clist -> 'a clist -> bool
-A useful check to assert before an append. It checks that the two lists - are not identically the same (Except if they are both empty)
-
-
val length : 'a clist -> int
-Find the length of a clist
-
-
val map : ('a -> 'b) -> 'a clist -> 'b clist
-Map a function over a clist. Returns another clist
-
-
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b clist -> 'a
-A version of fold_left that works on clists
-
-
val iter : ('a -> unit) -> 'a clist -> unit
-A version of iter that works on clists
-
-
val rev : ('a -> 'a) -> 'a clist -> 'a clist
-Reverse a clist. The first function reverses an element.
-
-
val docCList : Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a clist -> Pretty.doc
-A document for printing a clist (similar to docList)
-
- \ No newline at end of file diff --git a/cil/doc/api/Dataflow.BackwardsDataFlow.html b/cil/doc/api/Dataflow.BackwardsDataFlow.html deleted file mode 100644 index 782d318..0000000 --- a/cil/doc/api/Dataflow.BackwardsDataFlow.html +++ /dev/null @@ -1,54 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.BackwardsDataFlow - - -
Previous - Up - 
-

Functor Dataflow.BackwardsDataFlow

-
-
module BackwardsDataFlow: 
functor (T : BackwardsTransfer) -> sig .. end
- - - - -
Parameters: - - - - -
-T:BackwardsTransfer -
-
-
-
val compute : Cil.stmt list -> unit
-Fill in the T.stmtStartData, given a number of initial statements to - start from (the sinks for the backwards data flow). All of the statements - (not just the initial ones!) must have some entry in T.stmtStartData - (i.e., the initial data should not be bottom)
-
- \ No newline at end of file diff --git a/cil/doc/api/Dataflow.BackwardsTransfer.html b/cil/doc/api/Dataflow.BackwardsTransfer.html deleted file mode 100644 index 0ff812d..0000000 --- a/cil/doc/api/Dataflow.BackwardsTransfer.html +++ /dev/null @@ -1,83 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.BackwardsTransfer - - -
Previous - Up - 
-

Module type Dataflow.BackwardsTransfer

-
-
module type BackwardsTransfer = sig .. end
-
val name : string
-For debugging purposes, the name of the analysis
-
-
val debug : bool Pervasives.ref
-Whether to turn on debugging
-
-
type t
-
-The type of the data we compute for each block start. In many - presentations of backwards data flow analysis we maintain the - data at the block end. This is not easy to do with JVML because - a block has many exceptional ends. So we maintain the data for - the statement start.
-
- -
val pretty : unit -> t -> Pretty.doc
-Pretty-print the state
-
-
val stmtStartData : t Inthash.t
-For each block id, the data at the start. This data structure must be - initialized with the initial data for each block
-
-
val combineStmtStartData : Cil.stmt ->
       old:t ->
       t -> t option
-When the analysis reaches the start of a block, combine the old data - with the one we have just computed. Return None if the combination is - the same as the old data, otherwise return the combination. In the - latter case, the predecessors of the statement are put on the working - list.
-
-
val combineSuccessors : t ->
       t -> t
-Take the data from two successors and combine it
-
-
val doStmt : Cil.stmt -> t Dataflow.action
-The (backwards) transfer function for a branch. The Cil.currentLoc is - set before calling this. If it returns None, then we have some default - handling. Otherwise, the returned data is the data before the branch - (not considering the exception handlers)
-
-
val doInstr : Cil.instr ->
       t -> t Dataflow.action
-The (backwards) transfer function for an instruction. The - Cil.currentLoc is set before calling this. If it returns None, then we - have some default handling. Otherwise, the returned data is the data - before the branch (not considering the exception handlers)
-
-
val filterStmt : Cil.stmt -> Cil.stmt -> bool
-Whether to put this predecessor block in the worklist. We give the - predecessor and the block whose predecessor we are (and whose data has - changed)
-
- \ No newline at end of file diff --git a/cil/doc/api/Dataflow.ForwardsDataFlow.html b/cil/doc/api/Dataflow.ForwardsDataFlow.html deleted file mode 100644 index 760dc2b..0000000 --- a/cil/doc/api/Dataflow.ForwardsDataFlow.html +++ /dev/null @@ -1,53 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.ForwardsDataFlow - - -
 Up - Next -
-

Functor Dataflow.ForwardsDataFlow

-
-
module ForwardsDataFlow: 
functor (T : ForwardsTransfer) -> sig .. end
- - - - -
Parameters: - - - - -
-T:ForwardsTransfer -
-
-
-
val compute : Cil.stmt list -> unit
-Fill in the T.stmtStartData, given a number of initial statements to - start from. All of the initial statements must have some entry in - T.stmtStartData (i.e., the initial data should not be bottom)
-
- \ No newline at end of file diff --git a/cil/doc/api/Dataflow.ForwardsTransfer.html b/cil/doc/api/Dataflow.ForwardsTransfer.html deleted file mode 100644 index dbefaa0..0000000 --- a/cil/doc/api/Dataflow.ForwardsTransfer.html +++ /dev/null @@ -1,88 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.ForwardsTransfer - - -
 Up - Next -
-

Module type Dataflow.ForwardsTransfer

-
-
module type ForwardsTransfer = sig .. end
-
val name : string
-For debugging purposes, the name of the analysis
-
-
val debug : bool Pervasives.ref
-Whether to turn on debugging
-
-
type t
-
-The type of the data we compute for each block start. May be - imperative.
-
- -
val copy : t -> t
-Make a deep copy of the data
-
-
val stmtStartData : t Inthash.t
-For each statement id, the data at the start. Not found in the hash - table means nothing is known about the state at this point. At the end - of the analysis this means that the block is not reachable.
-
-
val pretty : unit -> t -> Pretty.doc
-Pretty-print the state
-
-
val computeFirstPredecessor : Cil.stmt -> t -> t
-Give the first value for a predecessors, compute the value to be set - for the block
-
-
val combinePredecessors : Cil.stmt ->
       old:t ->
       t -> t option
-Take some old data for the start of a statement, and some new data for - the same point. Return None if the combination is identical to the old - data. Otherwise, compute the combination, and return it.
-
-
val doInstr : Cil.instr ->
       t -> t Dataflow.action
-The (forwards) transfer function for an instruction. The - Cil.currentLoc is set before calling this. The default action is to - continue with the state unchanged.
-
-
val doStmt : Cil.stmt ->
       t ->
       t Dataflow.stmtaction
-The (forwards) transfer function for a statement. The Cil.currentLoc - is set before calling this. The default action is to do the instructions - in this statement, if applicable, and continue with the successors.
-
-
val doGuard : Cil.exp ->
       t ->
       t Dataflow.guardaction
-Generate the successor to an If statement assuming the given expression - is nonzero. Analyses that don't need guard information can return - GDefault; this is equivalent to returning GUse of the input. - A return value of GUnreachable indicates that this half of the branch - will not be taken and should not be explored. This will be called - twice per If, once for "then" and once for "else".
-
-
val filterStmt : Cil.stmt -> bool
-Whether to put this statement in the worklist. This is called when a - block would normally be put in the worklist.
-
- \ No newline at end of file diff --git a/cil/doc/api/Dataflow.html b/cil/doc/api/Dataflow.html deleted file mode 100644 index 9f744ea..0000000 --- a/cil/doc/api/Dataflow.html +++ /dev/null @@ -1,114 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow - - -
Previous - Up - Next -
-

Module Dataflow

-
-
module Dataflow: sig .. end
A framework for data flow analysis for CIL code. Before using - this framework, you must initialize the Control-flow Graph for your - program, e.g using Cfg.computeFileCFG
-
-
type 'a action = - - - - - - - - - - - - - - -
-| -Default(*The default action*)
-| -Done of 'a(*Do not do the default action. Use this result*)
-| -Post of ('a -> 'a)(*The default action, followed by the given - transformer*)
- - -
type 'a stmtaction = - - - - - - - - - - - - - - -
-| -SDefault(*The default action*)
-| -SDone(*Do not visit this statement or its successors*)
-| -SUse of 'a(*Visit the instructions and successors of this statement - as usual, but use the specified state instead of the - one that was passed to doStmt*)
- - -
type 'a guardaction = - - - - - - - - - - - - - - -
-| -GDefault(*The default state*)
-| -GUse of 'a(*Use this data for the branch*)
-| -GUnreachable(*The branch will never be taken.*)
- - -
module type ForwardsTransfer = sig .. end
module ForwardsDataFlow: 
functor (T : ForwardsTransfer) -> sig .. end
module type BackwardsTransfer = sig .. end
module BackwardsDataFlow: 
functor (T : BackwardsTransfer) -> sig .. end
\ No newline at end of file diff --git a/cil/doc/api/Dominators.html b/cil/doc/api/Dominators.html deleted file mode 100644 index 4d8eaf9..0000000 --- a/cil/doc/api/Dominators.html +++ /dev/null @@ -1,58 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dominators - - -
Previous - Up - 
-

Module Dominators

-
-
module Dominators: sig .. end
Compute dominators using data flow analysis
-
-
-Author: George Necula - 5/28/2004 -
-
val computeIDom : Cil.fundec -> Cil.stmt option Inthash.t
-Invoke on a code after filling in the CFG info and it computes the - immediate dominator information. We map each statement to its immediate - dominator (None for the start statement, and for the unreachable - statements).
-
-
val getIdom : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option
-This is like Inthash.find but gives an error if the information is - Not_found
-
-
val dominates : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool
-Check whether one statement dominates another.
-
-
val findNaturalLoops : Cil.fundec -> Cil.stmt option Inthash.t -> (Cil.stmt * Cil.stmt list) list
-Compute the start of the natural loops. This assumes that the "idom" - field has been computed. For each start, keep a list of origin of a back - edge. The loop consists of the loop start and all predecessors of the - origins of back edges, up to and including the loop start
-
- \ No newline at end of file diff --git a/cil/doc/api/Errormsg.html b/cil/doc/api/Errormsg.html deleted file mode 100644 index bc19472..0000000 --- a/cil/doc/api/Errormsg.html +++ /dev/null @@ -1,141 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Errormsg - - -
Previous - Up - Next -
-

Module Errormsg

-
-
module Errormsg: sig .. end
Utility functions for error-reporting
-
-
val logChannel : Pervasives.out_channel Pervasives.ref
-A channel for printing log messages
-
-
val debugFlag : bool Pervasives.ref
-If set then print debugging info
-
-
val verboseFlag : bool Pervasives.ref
val warnFlag : bool Pervasives.ref
-Set to true if you want to see all warnings.
-
-
exception Error
-
-Error reporting functions raise this exception
-
-
val error : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Prints an error message of the form Error: .... - Use in conjunction with s, for example: E.s (E.error ... ).
-
-
val bug : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Similar to error except that its output has the form Bug: ...
-
-
val unimp : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Similar to error except that its output has the form Unimplemented: ...
-
-
val s : 'a -> 'b
-Stop the execution by raising an Error.
-
-
val hadErrors : bool Pervasives.ref
-This is set whenever one of the above error functions are called. It must - be cleared manually
-
-
val warn : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Like Errormsg.error but does not raise the Errormsg.Error - exception. Return type is unit.
-
-
val warnOpt : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Like Errormsg.warn but optional. Printed only if the - Errormsg.warnFlag is set
-
-
val log : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Print something to logChannel
-
-
val logg : ('a, unit, Pretty.doc, unit) format4 -> 'a
-same as Errormsg.log but do not wrap lines
-
-
val null : ('a, unit, Pretty.doc, unit) format4 -> 'a
-Do not actually print (i.e. print to /dev/null)
-
-
val pushContext : (unit -> Pretty.doc) -> unit
-Registers a context printing function
-
-
val popContext : unit -> unit
-Removes the last registered context printing function
-
-
val showContext : unit -> unit
-Show the context stack to stderr
-
-
val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b
-To ensure that the context is registered and removed properly, use the - function below
-
-
val newline : unit -> unit
val newHline : unit -> unit
val getPosition : unit -> int * string * int
val getHPosition : unit -> int * string
-high-level position
-
-
val setHLine : int -> unit
val setHFile : string -> unit
val setCurrentLine : int -> unit
val setCurrentFile : string -> unit

type location = { - - - - - - - - - - - - - - - - - - - -
-   -file : string;(*The file name*)
-   -line : int;(*The line number*)
-   -hfile : string;(*The high-level file name, or "" if not present*)
-   -hline : int;(*The high-level line number, or 0 if not present*)
-} - -
-Type for source-file locations
-
- -
val d_loc : unit -> location -> Pretty.doc
val d_hloc : unit -> location -> Pretty.doc
val getLocation : unit -> location
val parse_error : string -> 'a
val locUnknown : location
-An unknown location for use when you need one but you don't have one
-
-
val readingFromStdin : bool Pervasives.ref
-Records whether the stdin is open for reading the goal *
-
-
val startParsing : ?useBasename:bool -> string -> Lexing.lexbuf
val startParsingFromString : ?file:string -> ?line:int -> string -> Lexing.lexbuf
val finishParsing : unit -> unit
\ No newline at end of file diff --git a/cil/doc/api/Formatcil.html b/cil/doc/api/Formatcil.html deleted file mode 100644 index 8dee76d..0000000 --- a/cil/doc/api/Formatcil.html +++ /dev/null @@ -1,84 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Formatcil - - -
Previous - Up - Next -
-

Module Formatcil

-
-
module Formatcil: sig .. end
An Interpreter for constructing CIL constructs
-
-
val cExp : string -> (string * Cil.formatArg) list -> Cil.exp
-Constructs an expression based on the program and the list of arguments. - Each argument consists of a name followed by the actual data. This - argument will be placed instead of occurrences of "%v:name" in the pattern - (where the "v" is dependent on the type of the data). The parsing of the - string is memoized. * Only the first expression is parsed.
-
-
val cLval : string -> (string * Cil.formatArg) list -> Cil.lval
-Constructs an lval based on the program and the list of arguments. - Only the first lvalue is parsed. - The parsing of the string is memoized.
-
-
val cType : string -> (string * Cil.formatArg) list -> Cil.typ
-Constructs a type based on the program and the list of arguments. - Only the first type is parsed. - The parsing of the string is memoized.
-
-
val cInstr : string -> Cil.location -> (string * Cil.formatArg) list -> Cil.instr
-Constructs an instruction based on the program and the list of arguments. - Only the first instruction is parsed. - The parsing of the string is memoized.
-
-
val cStmt : string ->
       (string -> Cil.typ -> Cil.varinfo) ->
       Cil.location -> (string * Cil.formatArg) list -> Cil.stmt
val cStmts : string ->
       (string -> Cil.typ -> Cil.varinfo) ->
       Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list
-Constructs a list of statements
-
-
val dExp : string -> Cil.exp -> Cil.formatArg list option
-Deconstructs an expression based on the program. Produces an optional - list of format arguments. The parsing of the string is memoized.
-
-
val dLval : string -> Cil.lval -> Cil.formatArg list option
-Deconstructs an lval based on the program. Produces an optional - list of format arguments. The parsing of the string is memoized.
-
-
val dType : string -> Cil.typ -> Cil.formatArg list option
-Deconstructs a type based on the program. Produces an optional list of - format arguments. The parsing of the string is memoized.
-
-
val dInstr : string -> Cil.instr -> Cil.formatArg list option
-Deconstructs an instruction based on the program. Produces an optional - list of format arguments. The parsing of the string is memoized.
-
-
val noMemoize : bool Pervasives.ref
-If set then will not memoize the parsed patterns
-
-
val test : unit -> unit
-Just a testing function
-
- \ No newline at end of file diff --git a/cil/doc/api/Pretty.MakeMapPrinter.html b/cil/doc/api/Pretty.MakeMapPrinter.html deleted file mode 100644 index 9693a68..0000000 --- a/cil/doc/api/Pretty.MakeMapPrinter.html +++ /dev/null @@ -1,63 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Pretty.MakeMapPrinter - - -
 Up - Next -
-

Functor Pretty.MakeMapPrinter

-
-
module MakeMapPrinter: 
functor (Map : sig
type key 

-
-
type 'a t 

-
-
val fold : (key -> 'a -> 'b -> 'b) ->
       'a t -> 'b -> 'b
end) -> sig .. end
Format maps.
- - - - - -
Parameters: - - - - -
-Map:sig - type key - type 'a t - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - end -
-
-
-
val docMap : ?sep:Pretty.doc ->
       (Map.key -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
-Format a map, analogous to docList.
-
-
val d_map : ?dmaplet:(Pretty.doc -> Pretty.doc -> Pretty.doc) ->
       string ->
       (unit -> Map.key -> Pretty.doc) ->
       (unit -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
-Format a map, analogous to d_list.
-
- \ No newline at end of file diff --git a/cil/doc/api/Pretty.MakeSetPrinter.html b/cil/doc/api/Pretty.MakeSetPrinter.html deleted file mode 100644 index e9343b2..0000000 --- a/cil/doc/api/Pretty.MakeSetPrinter.html +++ /dev/null @@ -1,63 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Pretty.MakeSetPrinter - - -
Previous - Up - 
-

Functor Pretty.MakeSetPrinter

-
-
module MakeSetPrinter: 
functor (Set : sig
type elt 

-
-
type t 

-
-
val fold : (elt -> 'a -> 'a) ->
       t -> 'a -> 'a
end) -> sig .. end
Format sets.
- - - - - -
Parameters: - - - - -
-Set:sig - type elt - type t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - end -
-
-
-
val docSet : ?sep:Pretty.doc -> (Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
-Format a set, analogous to docList.
-
-
val d_set : string -> (unit -> Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
-Format a set, analogous to d_list.
-
- \ No newline at end of file diff --git a/cil/doc/api/Pretty.html b/cil/doc/api/Pretty.html deleted file mode 100644 index c9c48c8..0000000 --- a/cil/doc/api/Pretty.html +++ /dev/null @@ -1,268 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Pretty - - -
 Up - Next -
-

Module Pretty

-
-
module Pretty: sig .. end
Utility functions for pretty-printing. The major features provided by - this module are
    -
  • An fprintf-style interface with support for user-defined printers
    • -
  • The printout is fit to a width by selecting some of the optional newlines
    • -
  • Constructs for alignment and indentation
    • -
  • Print ellipsis starting at a certain nesting depth
    • -
  • Constructs for printing lists and arrays
    • -
- - Pretty-printing occurs in two stages:
    -
  • Construct a Pretty.doc object that encodes all of the elements to be - printed - along with alignment specifiers and optional and mandatory newlines
    • -
  • Format the Pretty.doc to a certain width and emit it as a string, to an - output stream or pass it to a user-defined function
    • -
- - The formatting algorithm is not optimal but it does a pretty good job while - still operating in linear time. The original version was based on a pretty - printer by Philip Wadler which turned out to not scale to large jobs.
-
-
-API
-
type doc
-
-The type of unformated documents. Elements of this type can be - constructed in two ways. Either with a number of constructor shown below, - or using the Pretty.dprintf function with a printf-like interface. - The Pretty.dprintf method is slightly slower so we do not use it for - large jobs such as the output routines for a compiler. But we use it for - small jobs such as logging and error messages.
-
- -
-Constructors for the doc type.
-
val nil : doc
-Constructs an empty document
-
-
val (++) : doc -> doc -> doc
-Concatenates two documents. This is an infix operator that associates to - the left.
-
-
val concat : doc -> doc -> doc
val text : string -> doc
-A document that prints the given string
-
-
val num : int -> doc
-A document that prints an integer in decimal form
-
-
val real : float -> doc
-A document that prints a real number
-
-
val chr : char -> doc
-A document that prints a character. This is just like Pretty.text - with a one-character string.
-
-
val line : doc
-A document that consists of a mandatory newline. This is just like (text - "\n"). The new line will be indented to the current indentation level, - unless you use Pretty.leftflush right after this.
-
-
val leftflush : doc
-Use after a Pretty.line to prevent the indentation. Whatever follows - next will be flushed left. Indentation resumes on the next line.
-
-
val break : doc
-A document that consists of either a space or a line break. Also called - an optional line break. Such a break will be - taken only if necessary to fit the document in a given width. If the break - is not taken a space is printed instead.
-
-
val align : doc
-Mark the current column as the current indentation level. Does not print - anything. All taken line breaks will align to this column. The previous - alignment level is saved on a stack.
-
-
val unalign : doc
-Reverts to the last saved indentation level.
-
-
val mark : doc
-Mark the beginning of a markup section. The width of a markup section is - considered 0 for the purpose of computing identation
-
-
val unmark : doc
-The end of a markup section
-
-
-Syntactic sugar
-
val indent : int -> doc -> doc
-Indents the document. Same as ((text " ") ++ align ++ doc ++ unalign), - with the specified number of spaces.
-
-
val markup : doc -> doc
-Prints a document as markup. The marked document cannot contain line - breaks or alignment constructs.
-
-
val seq : sep:doc -> doit:('a -> doc) -> elements:'a list -> doc
-Formats a sequence. sep is a separator, doit is a function that - converts an element to a document.
-
-
val docList : ?sep:doc -> ('a -> doc) -> unit -> 'a list -> doc
-An alternative function for printing a list. The unit argument is there - to make this function more easily usable with the Pretty.dprintf - interface. The first argument is a separator, by default a comma.
-
-
val d_list : string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc
-sm: Yet another list printer. This one accepts the same kind of - printing function that Pretty.dprintf does, and itself works - in the dprintf context. Also accepts - a string as the separator since that's by far the most common.
-
-
val docArray : ?sep:doc ->
       (int -> 'a -> doc) -> unit -> 'a array -> doc
-Formats an array. A separator and a function that prints an array - element. The default separator is a comma.
-
-
val docOpt : ('a -> doc) -> unit -> 'a option -> doc
-Prints an 'a option with None or Some
-
-
val d_int32 : int32 -> doc
-Print an int32
-
-
val f_int32 : unit -> int32 -> doc
val d_int64 : int64 -> doc
val f_int64 : unit -> int64 -> doc
module MakeMapPrinter: 
functor (Map : sig
type key 

-
-
type 'a t 

-
-
val fold : (key -> 'a -> 'b -> 'b) ->
       'a t -> 'b -> 'b
end) -> sig .. end
-Format maps. -
-
module MakeSetPrinter: 
functor (Set : sig
type elt 

-
-
type t 

-
-
val fold : (elt -> 'a -> 'a) ->
       t -> 'a -> 'a
end) -> sig .. end
-Format sets. -
-
val insert : unit -> doc -> doc
-A function that is useful with the printf-like interface
-
-
val dprintf : ('a, unit, doc, doc) format4 -> 'a
-This function provides an alternative method for constructing - doc objects. The first argument for this function is a format string - argument (of type ('a, unit, doc) format; if you insist on - understanding what that means see the module Printf). The format string - is like that for the printf function in C, except that it understands a - few more formatting controls, all starting with the @ character. -

- - See the gprintf function if you want to pipe the result of dprintf into - some other functions. -

- - The following special formatting characters are understood (these do not - correspond to arguments of the function):

- - In addition to the usual printf % formatting characters the following two - new characters are supported:
    -
  • %t Corresponds to an argument of type unit -> doc. This argument is - invoked to produce a document
    • -
  • %a Corresponds to two arguments. The first of type unit -> 'a -> doc - and the second of type 'a. (The extra unit is do to the - peculiarities of the built-in support for format strings in Ocaml. It - turns out that it is not a major problem.) Here is an example of how - you use this:
    • -
- -
dprintf "Name=%s, SSN=%7d, Children=@[%a@]\n"
-             pers.name pers.ssn (docList (chr ',' ++ break) text)
-             pers.children
-

- - The result of dprintf is a Pretty.doc. You can format the document and - emit it using the functions Pretty.fprint and Pretty.sprint.
-

-
val gprintf : (doc -> 'a) -> ('b, unit, doc, 'a) format4 -> 'b
-Like Pretty.dprintf but more general. It also takes a function that is - invoked on the constructed document but before any formatting is done. The - type of the format argument means that 'a is the type of the parameters of - this function, unit is the type of the first argument to %a and %t - formats, doc is the type of the intermediate result, and 'b is the type of - the result of gprintf.
-
-
val fprint : Pervasives.out_channel -> width:int -> doc -> unit
-Format the document to the given width and emit it to the given channel
-
-
val sprint : width:int -> doc -> string
-Format the document to the given width and emit it as a string
-
-
val fprintf : Pervasives.out_channel -> ('a, unit, doc) Pervasives.format -> 'a
-Like Pretty.dprintf followed by Pretty.fprint
-
-
val printf : ('a, unit, doc) Pervasives.format -> 'a
-Like Pretty.fprintf applied to stdout
-
-
val eprintf : ('a, unit, doc) Pervasives.format -> 'a
-Like Pretty.fprintf applied to stderr
-
-
val withPrintDepth : int -> (unit -> unit) -> unit
-Invokes a thunk, with printDepth temporarily set to the specified value
-
-
-The following variables can be used to control the operation of the printer
-
val printDepth : int Pervasives.ref
-Specifies the nesting depth of the align/unalign pairs at which - everything is replaced with ellipsis
-
-
val printIndent : bool Pervasives.ref
-If false then does not indent
-
-
val fastMode : bool Pervasives.ref
-If set to true then optional breaks are taken only when the document - has exceeded the given width. This means that the printout will looked - more ragged but it will be faster
-
-
val flushOften : bool Pervasives.ref
-If true the it flushes after every print
-
-
val countNewLines : int Pervasives.ref
-Keep a running count of the taken newlines. You can read and write this - from the client code if you want
-
-
val auto_printer : string -> 'a
-A function that when used at top-level in a module will direct - the pa_prtype module generate automatically the printing functions for a - type
-
- \ No newline at end of file diff --git a/cil/doc/api/Stats.html b/cil/doc/api/Stats.html deleted file mode 100644 index b3f8aa4..0000000 --- a/cil/doc/api/Stats.html +++ /dev/null @@ -1,69 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Stats - - -
Previous - Up - Next -
-

Module Stats

-
-
module Stats: sig .. end
Utilities for maintaining timing statistics
-
-
val reset : bool -> unit
-Resets all the timings. Invoke with "true" if you want to switch to using - the hardware performance counters from now on. You get an exception if - there are not performance counters available
-
-
exception NoPerfCount
-
val has_performance_counters : unit -> bool
-Check if we have performance counters
-
-
val sample_pentium_perfcount_20 : unit -> int
-Sample the current cycle count, in megacycles.
-
-
val sample_pentium_perfcount_10 : unit -> int
-Sample the current cycle count, in kilocycles.
-
-
val time : string -> ('a -> 'b) -> 'a -> 'b
-Time a function and associate the time with the given string. If some - timing information is already associated with that string, then accumulate - the times. If this function is invoked within another timed function then - you can have a hierarchy of timings
-
-
val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
-repeattime is like time but runs the function several times until the total - running time is greater or equal to the first argument. The total time is - then divided by the number of times the function was run.
-
-
val print : Pervasives.out_channel -> string -> unit
-Print the current stats preceeded by a message
-
-
val lastTime : float Pervasives.ref
-Time a function and set lastTime to the time it took
-
-
val timethis : ('a -> 'b) -> 'a -> 'b
\ No newline at end of file diff --git a/cil/doc/api/index.html b/cil/doc/api/index.html deleted file mode 100644 index f9636b2..0000000 --- a/cil/doc/api/index.html +++ /dev/null @@ -1,83 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) - - -

CIL API Documentation (version 1.3.5)

-Index of types
-Index of exceptions
-Index of values
-Index of class methods
-Index of classes
-Index of class types
-Index of modules
-Index of module types
-

- - - - - - - - - - - - -
Pretty
-Utility functions for pretty-printing. -
-
Errormsg
-Utility functions for error-reporting -
-
Clist
-Utilities for managing "concatenable lists" (clists). -
-
Stats
-Utilities for maintaining timing statistics -
-
Cil
-CIL API Documentation. -
-
Formatcil
-An Interpreter for constructing CIL constructs -
-
Alpha
-ALPHA conversion -
-
Cillower
-A number of lowering passes over CIL -
-
Cfg
-Code to compute the control-flow graph of a function or file. -
-
Dataflow
-A framework for data flow analysis for CIL code. -
-
Dominators
-Compute dominators using data flow analysis -
-
- - \ No newline at end of file diff --git a/cil/doc/api/index_attributes.html b/cil/doc/api/index_attributes.html deleted file mode 100644 index 347bfa9..0000000 --- a/cil/doc/api/index_attributes.html +++ /dev/null @@ -1,30 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of class attributes - - -

Index of class attributes

- -

- - \ No newline at end of file diff --git a/cil/doc/api/index_class_types.html b/cil/doc/api/index_class_types.html deleted file mode 100644 index 4c7faef..0000000 --- a/cil/doc/api/index_class_types.html +++ /dev/null @@ -1,41 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of class types - - -

Index of class types

- - - - - - -

C
cilPrinter [Cil]
-A printer interface for CIL trees. -
-
cilVisitor [Cil]
-A visitor interface for traversing CIL trees. -
-

- - \ No newline at end of file diff --git a/cil/doc/api/index_classes.html b/cil/doc/api/index_classes.html deleted file mode 100644 index 1a5ba7d..0000000 --- a/cil/doc/api/index_classes.html +++ /dev/null @@ -1,46 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of classes - - -

Index of classes

- - - - - - - - - - -

D
defaultCilPrinterClass [Cil]

N
nopCilVisitor [Cil]
-Default Visitor. -
-

P
plainCilPrinterClass [Cil]
-These are pretty-printers that will show you more details on the internal - CIL representation, without trying hard to make it look like C -
-

- - \ No newline at end of file diff --git a/cil/doc/api/index_exceptions.html b/cil/doc/api/index_exceptions.html deleted file mode 100644 index e774a65..0000000 --- a/cil/doc/api/index_exceptions.html +++ /dev/null @@ -1,53 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of exceptions - - -

Index of exceptions

- - - - - - - - - - - - - -

E
Error [Errormsg]
-Error reporting functions raise this exception -
-

L
LenOfArray [Cil]
-Raised when Cil.lenOfArray fails either because the length is None - or because it is a non-constant expression -
-

N
NoPerfCount [Stats]

S
SizeOfError [Cil]
-Raised when one of the bitsSizeOf functions cannot compute the size of a - type. -
-

- - \ No newline at end of file diff --git a/cil/doc/api/index_methods.html b/cil/doc/api/index_methods.html deleted file mode 100644 index 1558de3..0000000 --- a/cil/doc/api/index_methods.html +++ /dev/null @@ -1,228 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of class methods - - -

Index of class methods

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

D
dBlock [Cil.cilPrinter]
-Dump a control-flow block to a file with a given indentation. -
-
dGlobal [Cil.cilPrinter]
-Dump a global to a file with a given indentation. -
-
dInit [Cil.cilPrinter]
-Dump a global to a file with a given indentation. -
-
dStmt [Cil.cilPrinter]
-Dump a control-flow statement to a file with a given indentation. -
-

P
pAttr [Cil.cilPrinter]
-Attribute. -
-
pAttrParam [Cil.cilPrinter]
-Attribute parameter -
-
pAttrs [Cil.cilPrinter]
-Attribute lists -
-
pBlock [Cil.cilPrinter]
pExp [Cil.cilPrinter]
-Print expressions -
-
pFieldDecl [Cil.cilPrinter]
-A field declaration -
-
pGlobal [Cil.cilPrinter]
-Global (vars, types, etc.). -
-
pInit [Cil.cilPrinter]
-Print initializers. -
-
pInstr [Cil.cilPrinter]
-Invoked on each instruction occurrence. -
-
pLabel [Cil.cilPrinter]
-Print a label. -
-
pLineDirective [Cil.cilPrinter]
-Print a line-number. -
-
pLval [Cil.cilPrinter]
-Invoked on each lvalue occurrence -
-
pOffset [Cil.cilPrinter]
-Invoked on each offset occurrence. -
-
pStmt [Cil.cilPrinter]
-Control-flow statement. -
-
pStmtKind [Cil.cilPrinter]
-Print a statement kind. -
-
pType [Cil.cilPrinter]
pVDecl [Cil.cilPrinter]
-Invoked for each variable declaration. -
-
pVar [Cil.cilPrinter]
-Invoked on each variable use. -
-

Q
queueInstr [Cil.cilVisitor]
-Add here instructions while visiting to queue them to preceede the - current statement or instruction being processed. -
-

U
unqueueInstr [Cil.cilVisitor]
-Gets the queue of instructions and resets the queue. -
-

V
vattr [Cil.cilVisitor]
-Attribute. -
-
vattrparam [Cil.cilVisitor]
-Attribute parameters. -
-
vblock [Cil.cilVisitor]
-Block. -
-
vexpr [Cil.cilVisitor]
-Invoked on each expression occurrence. -
-
vfunc [Cil.cilVisitor]
-Function definition. -
-
vglob [Cil.cilVisitor]
-Global (vars, types, - etc.) -
-
vinit [Cil.cilVisitor]
-Initializers for globals -
-
vinitoffs [Cil.cilVisitor]
-Invoked on each offset appearing in the list of a - CompoundInit initializer. -
-
vinst [Cil.cilVisitor]
-Invoked on each instruction occurrence. -
-
vlval [Cil.cilVisitor]
-Invoked on each lvalue occurrence -
-
voffs [Cil.cilVisitor]
-Invoked on each offset occurrence that is *not* as part - of an initializer list specification, i.e. -
-
vstmt [Cil.cilVisitor]
-Control-flow statement. -
-
vtype [Cil.cilVisitor]
-Use of some type. -
-
vvdec [Cil.cilVisitor]
-Invoked for each variable declaration. -
-
vvrbl [Cil.cilVisitor]
-Invoked on each variable use. -
-

- - \ No newline at end of file diff --git a/cil/doc/api/index_module_types.html b/cil/doc/api/index_module_types.html deleted file mode 100644 index 244d402..0000000 --- a/cil/doc/api/index_module_types.html +++ /dev/null @@ -1,36 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of module types - - -

Index of module types

- - - - - - - -

B
BackwardsTransfer [Dataflow]

F
ForwardsTransfer [Dataflow]

- - \ No newline at end of file diff --git a/cil/doc/api/index_modules.html b/cil/doc/api/index_modules.html deleted file mode 100644 index 090693f..0000000 --- a/cil/doc/api/index_modules.html +++ /dev/null @@ -1,108 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of modules - - -

Index of modules

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

A
Alpha
-ALPHA conversion -
-

B
BackwardsDataFlow [Dataflow]

C
Cfg
-Code to compute the control-flow graph of a function or file. -
-
Cil
-CIL API Documentation. -
-
Cillower
-A number of lowering passes over CIL -
-
Clist
-Utilities for managing "concatenable lists" (clists). -
-

D
Dataflow
-A framework for data flow analysis for CIL code. -
-
Dominators
-Compute dominators using data flow analysis -
-

E
Errormsg
-Utility functions for error-reporting -
-

F
Formatcil
-An Interpreter for constructing CIL constructs -
-
ForwardsDataFlow [Dataflow]

M
MakeMapPrinter [Pretty]
-Format maps. -
-
MakeSetPrinter [Pretty]
-Format sets. -
-

P
Pretty
-Utility functions for pretty-printing. -
-

S
Stats
-Utilities for maintaining timing statistics -
-

- - \ No newline at end of file diff --git a/cil/doc/api/index_types.html b/cil/doc/api/index_types.html deleted file mode 100644 index 1974acd..0000000 --- a/cil/doc/api/index_types.html +++ /dev/null @@ -1,271 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of types - - -

Index of types

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

A
action [Dataflow]
alphaTableData [Alpha]
-This is the type of the elements of the alpha renaming table. -
-
attribute [Cil]
attributeClass [Cil]
-Various classes of attributes -
-
attributes [Cil]
-Attributes are lists sorted by the attribute name. -
-
attrparam [Cil]
-The type of parameters of attributes -
-

B
binop [Cil]
-Binary operations -
-
block [Cil]
-A block is a sequence of statements with the control falling through from - one element to the next -
-

C
clist [Clist]
-The clist datatype. -
-
comment [Cil]
compinfo [Cil]
-The definition of a structure or union type. -
-
constant [Cil]
-Literal constants -
-

D
doc [Pretty]
-The type of unformated documents. -
-

E
enuminfo [Cil]
-Information about an enumeration -
-
existsAction [Cil]
-A datatype to be used in conjunction with existsType -
-
exp [Cil]
-Expressions (Side-effect free) -
-

F
featureDescr [Cil]
-To be able to add/remove features easily, each feature should be package - as an interface with the following interface. -
-
fieldinfo [Cil]
-Information about a struct/union field -
-
file [Cil]
-Top-level representation of a C source file -
-
fkind [Cil]
-Various kinds of floating-point numbers -
-
formatArg [Cil]
-The type of argument for the interpreter -
-
fundec [Cil]
-Function definitions. -
-

G
global [Cil]
-A global declaration or definition -
-
guardaction [Dataflow]

I
ikind [Cil]
-Various kinds of integers -
-
init [Cil]
-Initializers for global variables. -
-
initinfo [Cil]
-We want to be able to update an initializer in a global variable, so we - define it as a mutable field -
-
instr [Cil]
-Instructions. -
-

L
label [Cil]
-Labels -
-
lhost [Cil]
-The host part of an Cil.lval. -
-
lineDirectiveStyle [Cil]
-Styles of printing line directives -
-
location [Cil]
-Describes a location in a source file. -
-
location [Errormsg]
-Type for source-file locations -
-
lval [Cil]
-An lvalue -
-

O
offset [Cil]
-The offset part of an Cil.lval. -
-

S
stmt [Cil]
-Statements. -
-
stmtaction [Dataflow]
stmtkind [Cil]
-The various kinds of control-flow statements statements -
-
storage [Cil]
-Storage-class information -
-

T
t [Dataflow.BackwardsTransfer]
-The type of the data we compute for each block start. -
-
t [Dataflow.ForwardsTransfer]
-The type of the data we compute for each block start. -
-
typ [Cil]
typeinfo [Cil]
-Information about a defined type -
-
typsig [Cil]
-Type signatures. -
-

U
undoAlphaElement [Alpha]
-This is the type of the elements that are recorded by the alpha - conversion functions in order to be able to undo changes to the tables - they modify. -
-
unop [Cil]
-Unary operators -
-

V
varinfo [Cil]
-Information about a variable. -
-
visitAction [Cil]
-Different visiting actions. -
-

- - \ No newline at end of file diff --git a/cil/doc/api/index_values.html b/cil/doc/api/index_values.html deleted file mode 100644 index 799daaf..0000000 --- a/cil/doc/api/index_values.html +++ /dev/null @@ -1,1964 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Index of values - - -

Index of values

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(++) [Pretty]
-Concatenates two documents. -
-

A
addAttribute [Cil]
-Add an attribute. -
-
addAttributes [Cil]
-Add a list of attributes. -
-
addOffset [Cil]
-addOffset o1 o2 adds o1 to the end of o2. -
-
addOffsetLval [Cil]
-Add an offset at the end of an lvalue. -
-
additiveLevel [Cil]
addrOfLevel [Cil]
align [Pretty]
-Mark the current column as the current indentation level. -
-
alignOf_int [Cil]
-The minimum alignment (in bytes) for a type. -
-
append [Clist]
-Append two clists -
-
argsToList [Cil]
-Obtain the argument list ([] if None) -
-
arrowLevel [Cil]
attributeHash [Cil]
-This table contains the mapping of predefined attributes to classes. -
-
auto_printer [Pretty]
-A function that when used at top-level in a module will direct - the pa_prtype module generate automatically the printing functions for a - type -
-

B
bitsOffset [Cil]
-Give a type of a base and an offset, returns the number of bits from the - base address and the width (also expressed in bits) for the subobject - denoted by the offset. -
-
bitsSizeOf [Cil]
-The size of a type, in bits. -
-
bitwiseLevel [Cil]
break [Pretty]
-A document that consists of either a space or a line break. -
-
bug [Cil]
-Like Errormsg.bug except that Cil.currentLoc is also printed -
-
bug [Errormsg]
-Similar to error except that its output has the form Bug: ... -
-

C
cExp [Formatcil]
-Constructs an expression based on the program and the list of arguments. -
-
cInstr [Formatcil]
-Constructs an instruction based on the program and the list of arguments. -
-
cLval [Formatcil]
-Constructs an lval based on the program and the list of arguments. -
-
cStmt [Formatcil]
cStmts [Formatcil]
-Constructs a list of statements -
-
cType [Formatcil]
-Constructs a type based on the program and the list of arguments. -
-
cfgFun [Cfg]
-Compute a control flow graph for fd. -
-
charConstPtrType [Cil]
-char const * -
-
charConstToInt [Cil]
-Given the character c in a (CChr c), sign-extend it to 32 bits. -
-
charPtrType [Cil]
-char * -
-
charType [Cil]
-char -
-
char_is_unsigned [Cil]
-Whether "char" is unsigned. -
-
checkBeforeAppend [Clist]
-A useful check to assert before an append. -
-
chr [Pretty]
-A document that prints a character. -
-
cilVersion [Cil]
-This are the CIL version numbers. -
-
cilVersionMajor [Cil]
cilVersionMinor [Cil]
cilVersionRevision [Cil]
clearCFGinfo [Cfg]
-clear the sid, succs, and preds fields of each statment in a function -
-
clearFileCFG [Cfg]
-clear the sid, succs, and preds fields of each statement. -
-
combinePredecessors [Dataflow.ForwardsTransfer]
-Take some old data for the start of a statement, and some new data for - the same point. -
-
combineStmtStartData [Dataflow.BackwardsTransfer]
-When the analysis reaches the start of a block, combine the old data - with the one we have just computed. -
-
combineSuccessors [Dataflow.BackwardsTransfer]
-Take the data from two successors and combine it -
-
compFullName [Cil]
-Get the full name of a comp -
-
compactStmts [Cil]
-Try to compress statements so as to get maximal basic blocks -
-
comparativeLevel [Cil]
compareLoc [Cil]
-Comparison function for locations. -
-
compute [Dataflow.BackwardsDataFlow]
-Fill in the T.stmtStartData, given a number of initial statements to - start from (the sinks for the backwards data flow). -
-
compute [Dataflow.ForwardsDataFlow]
-Fill in the T.stmtStartData, given a number of initial statements to - start from. -
-
computeCFGInfo [Cil]
-Compute the CFG information for all statements in a fundec and return a - list of the statements. -
-
computeFileCFG [Cfg]
-Compute the CFG for an entire file, by calling cfgFun on each function. -
-
computeFirstPredecessor [Dataflow.ForwardsTransfer]
-Give the first value for a predecessors, compute the value to be set - for the block -
-
computeIDom [Dominators]
-Invoke on a code after filling in the CFG info and it computes the - immediate dominator information. -
-
concat [Pretty]
constFold [Cil]
-Do constant folding on an expression. -
-
constFoldBinOp [Cil]
-Do constant folding on a binary operation. -
-
constFoldVisitor [Cil]
-A visitor that does constant folding. -
-
copy [Dataflow.ForwardsTransfer]
-Make a deep copy of the data -
-
copyCompInfo [Cil]
-Makes a shallow copy of a Cil.compinfo changing the name and the key. -
-
copyFunction [Cil]
-Create a deep copy of a function. -
-
copyVarinfo [Cil]
-Make a shallow copy of a varinfo and assign a new identifier -
-
countNewLines [Pretty]
-Keep a running count of the taken newlines. -
-
currentGlobal [Cil]
-A reference to the current global being visited -
-
currentLoc [Cil]
-A reference to the current location. -
-

D
dExp [Formatcil]
-Deconstructs an expression based on the program. -
-
dExp [Cil]
-Generate an Cil.exp to be used in case of errors. -
-
dGlobal [Cil]
-Generate a Cil.global to be used in case of errors. -
-
dInstr [Formatcil]
-Deconstructs an instruction based on the program. -
-
dInstr [Cil]
-Generate an Cil.instr to be used in case of errors. -
-
dLval [Formatcil]
-Deconstructs an lval based on the program. -
-
dType [Formatcil]
-Deconstructs a type based on the program. -
-
d_attr [Cil]
-Pretty-print an attribute using Cil.defaultCilPrinter -
-
d_attrlist [Cil]
-Pretty-print a list of attributes using Cil.defaultCilPrinter -
-
d_attrparam [Cil]
-Pretty-print an argument of an attribute using Cil.defaultCilPrinter -
-
d_binop [Cil]
-Pretty-print a binary operator -
-
d_block [Cil]
-Pretty-print a block using Cil.defaultCilPrinter. -
-
d_const [Cil]
-Pretty-print a constant -
-
d_exp [Cil]
-Pretty-print an expression using Cil.defaultCilPrinter -
-
d_fkind [Cil]
-Pretty-print a floating-point kind -
-
d_formatarg [Cil]
-Pretty-prints a format arg -
-
d_global [Cil]
-Pretty-print the internal representation of a global using - Cil.defaultCilPrinter. -
-
d_hloc [Errormsg]
d_ikind [Cil]
-Pretty-print an integer of a given kind -
-
d_init [Cil]
-Pretty-print an initializer using Cil.defaultCilPrinter. -
-
d_instr [Cil]
-Pretty-print an instruction using Cil.defaultCilPrinter -
-
d_int32 [Pretty]
-Print an int32 -
-
d_int64 [Pretty]
d_label [Cil]
-Pretty-print a label using Cil.defaultCilPrinter -
-
d_list [Pretty]
-sm: Yet another list printer. -
-
d_loc [Cil]
-Pretty-print a location -
-
d_loc [Errormsg]
d_lval [Cil]
-Pretty-print an lvalue using Cil.defaultCilPrinter -
-
d_map [Pretty.MakeMapPrinter]
-Format a map, analogous to d_list. -
-
d_offset [Cil]
-Pretty-print an offset using Cil.defaultCilPrinter, given the pretty - printing for the base. -
-
d_plainexp [Cil]
-Pretty-print the internal representation of an expression -
-
d_plaininit [Cil]
-Pretty-print the internal representation of an integer -
-
d_plainlval [Cil]
-Pretty-print the internal representation of an lvalue -
-
d_plaintype [Cil]
-Pretty-print the internal representation of a type -
-
d_set [Pretty.MakeSetPrinter]
-Format a set, analogous to d_list. -
-
d_shortglobal [Cil]
-Pretty-print a short description of the global. -
-
d_stmt [Cil]
-Pretty-print a statement using Cil.defaultCilPrinter. -
-
d_storage [Cil]
-Pretty-print storage-class information -
-
d_thisloc [Cil]
-Pretty-print the Cil.currentLoc -
-
d_type [Cil]
-Pretty-print a type using Cil.defaultCilPrinter -
-
d_typsig [Cil]
-Print a type signature -
-
d_unop [Cil]
-Pretty-print a unary operator -
-
debug [Dataflow.BackwardsTransfer]
-Whether to turn on debugging -
-
debug [Dataflow.ForwardsTransfer]
-Whether to turn on debugging -
-
debugFlag [Errormsg]
-If set then print debugging info -
-
defaultCilPrinter [Cil]
derefStarLevel [Cil]
dn_attr [Cil]
dn_attrlist [Cil]
dn_attrparam [Cil]
dn_exp [Cil]
-Versions of the above pretty printers, that don't print #line directives -
-
dn_global [Cil]
dn_init [Cil]
dn_instr [Cil]
dn_lval [Cil]
dn_stmt [Cil]
dn_type [Cil]
doGuard [Dataflow.ForwardsTransfer]
-Generate the successor to an If statement assuming the given expression - is nonzero. -
-
doInstr [Dataflow.BackwardsTransfer]
-The (backwards) transfer function for an instruction. -
-
doInstr [Dataflow.ForwardsTransfer]
-The (forwards) transfer function for an instruction. -
-
doStmt [Dataflow.BackwardsTransfer]
-The (backwards) transfer function for a branch. -
-
doStmt [Dataflow.ForwardsTransfer]
-The (forwards) transfer function for a statement. -
-
docAlphaTable [Alpha]
-Split the name in preparation for newAlphaName. -
-
docArray [Pretty]
-Formats an array. -
-
docCList [Clist]
-A document for printing a clist (similar to docList) -
-
docList [Pretty]
-An alternative function for printing a list. -
-
docMap [Pretty.MakeMapPrinter]
-Format a map, analogous to docList. -
-
docOpt [Pretty]
-Prints an 'a option with None or Some -
-
docSet [Pretty.MakeSetPrinter]
-Format a set, analogous to docList. -
-
dominates [Dominators]
-Check whether one statement dominates another. -
-
doubleType [Cil]
-double -
-
dprintf [Pretty]
-This function provides an alternative method for constructing - doc objects. -
-
dropAttribute [Cil]
-Remove all attributes with the given name. -
-
dropAttributes [Cil]
-Remove all attributes with names appearing in the string list. -
-
dummyFile [Cil]
-A dummy file -
-
dummyFunDec [Cil]
-A dummy function declaration handy when you need one as a placeholder. -
-
dummyInstr [Cil]
-A instr to serve as a placeholder -
-
dummyStmt [Cil]
-A statement consisting of just dummyInstr -
-
dumpBlock [Cil]
-Dump a block to a file using a given indentation. -
-
dumpFile [Cil]
-Pretty-print an entire file. -
-
dumpGlobal [Cil]
-Pretty-print a global. -
-
dumpInit [Cil]
-Dump an initializer to a file using a given indentation. -
-
dumpStmt [Cil]
-Dump a statement to a file using a given indentation. -
-

E
empty [Clist]
-The empty clist -
-
emptyFunction [Cil]
-Make an empty function -
-
eprintf [Pretty]
-Like Pretty.fprintf applied to stderr -
-
error [Cil]
-Like Errormsg.error except that Cil.currentLoc is also printed -
-
error [Errormsg]
-Prints an error message of the form Error: .... -
-
errorLoc [Cil]
-Like Cil.error except that it explicitly takes a location argument, - instead of using the Cil.currentLoc -
-
existsType [Cil]
-Scans a type by applying the function on all elements. -
-

F
f_int32 [Pretty]
f_int64 [Pretty]
fastMode [Pretty]
-If set to true then optional breaks are taken only when the document - has exceeded the given width. -
-
filterAttributes [Cil]
-Retains attributes with the given name -
-
filterStmt [Dataflow.BackwardsTransfer]
-Whether to put this predecessor block in the worklist. -
-
filterStmt [Dataflow.ForwardsTransfer]
-Whether to put this statement in the worklist. -
-
findNaturalLoops [Dominators]
-Compute the start of the natural loops. -
-
finishParsing [Errormsg]
flushOften [Pretty]
-If true the it flushes after every print -
-
foldGlobals [Cil]
-Fold over all globals, including the global initializer -
-
foldLeftCompound [Cil]
-Fold over the list of initializers in a Compound. -
-
foldLeftCompoundAll [Cil]
-Fold over the list of initializers in a Compound, like - Cil.foldLeftCompound but in the case of an array it scans even missing - zero initializers at the end of the array -
-
fold_left [Clist]
-A version of fold_left that works on clists -
-
forgcc [Cil]
-Return the string 's' if we're printing output for gcc, suppres - it if we're printing for CIL to parse back in. -
-
fprint [Pretty]
-Format the document to the given width and emit it to the given channel -
-
fprintf [Pretty]
-Like Pretty.dprintf followed by Pretty.fprint -
-
fromList [Clist]
-Convert an ordinary list to a clist -
-

G
gccBuiltins [Cil]
-A list of the GCC built-in functions. -
-
getAlphaPrefix [Alpha]
getCompField [Cil]
-Return a named fieldinfo in compinfo, or raise Not_found -
-
getGlobInit [Cil]
-Get the global initializer and create one if it does not already exist. -
-
getHPosition [Errormsg]
-high-level position -
-
getIdom [Dominators]
-This is like Inthash.find but gives an error if the information is - Not_found -
-
getLocation [Errormsg]
getParenthLevel [Cil]
-Parentheses level. -
-
getPosition [Errormsg]
get_globalLoc [Cil]
-Return the location of a global, or locUnknown -
-
get_instrLoc [Cil]
-Return the location of an instruction -
-
get_stmtLoc [Cil]
-Return the location of a statement, or locUnknown -
-
gprintf [Pretty]
-Like Pretty.dprintf but more general. -
-

H
hadErrors [Errormsg]
-This is set whenever one of the above error functions are called. -
-
hasAttribute [Cil]
-True if the named attribute appears in the attribute list. -
-
has_performance_counters [Stats]
-Check if we have performance counters -
-

I
increm [Cil]
-Increment an expression. -
-
indent [Pretty]
-Indents the document. -
-
indexLevel [Cil]
initCIL [Cil]
-Call this function to perform some initialization. -
-
insert [Pretty]
-A function that is useful with the printf-like interface -
-
insertImplicitCasts [Cil]
-Do insert implicit casts (default true) -
-
intPtrType [Cil]
-int * -
-
intType [Cil]
-int -
-
integer [Cil]
-Construct an integer of kind IInt. -
-
invalidStmt [Cil]
-An empty statement. -
-
isArithmeticType [Cil]
-True if the argument is an arithmetic type (i.e. -
-
isArrayType [Cil]
-True if the argument is an array type -
-
isCompleteType [Cil]
-Returns true if this is a complete type. -
-
isConstant [Cil]
-True if the expression is a compile-time constant -
-
isFunctionType [Cil]
-True if the argument is a function type -
-
isInteger [Cil]
-True if the given expression is a (possibly cast'ed) - character or an integer constant -
-
isIntegralType [Cil]
-True if the argument is an integral type (i.e. -
-
isPointerType [Cil]
-True if the argument is a pointer type -
-
isSigned [Cil]
-Returns true if and only if the given integer type is signed. -
-
isVoidPtrType [Cil]
isVoidType [Cil]
isZero [Cil]
-True if the given expression is a (possibly cast'ed) integer or character - constant with value zero -
-
iter [Clist]
-A version of iter that works on clists -
-
iterGlobals [Cil]
-Iterate over all globals, including the global initializer -
-

K
kinteger [Cil]
-Construct an integer of a given kind. -
-
kinteger64 [Cil]
-Construct an integer of a given kind, using OCaml's int64 type. -
-

L
lastTime [Stats]
-Time a function and set lastTime to the time it took -
-
leftflush [Pretty]
-Use after a Pretty.line to prevent the indentation. -
-
lenOfArray [Cil]
-Call to compute the array length as present in the array type, to an - integer. -
-
length [Clist]
-Find the length of a clist -
-
line [Pretty]
-A document that consists of a mandatory newline. -
-
lineDirectiveStyle [Cil]
-How to print line directives -
-
lineLength [Cil]
-The length used when wrapping output lines. -
-
little_endian [Cil]
-Whether the machine is little endian. -
-
loadBinaryFile [Cil]
-Read a Cil.file in binary form from the filesystem. -
-
locUnknown [Cil]
-Represents a location that cannot be determined -
-
locUnknown [Errormsg]
-An unknown location for use when you need one but you don't have one -
-
log [Errormsg]
-Print something to logChannel -
-
logChannel [Errormsg]
-A channel for printing log messages -
-
logg [Errormsg]
-same as Errormsg.log but do not wrap lines -
-
longType [Cil]
-long -
-
lowerConstants [Cil]
-Do lower constants (default true) -
-
lowerEnumVisitor [Cillower]
-Replace enumeration constants with integer constants -
-

M
makeFormalVar [Cil]
-Make a formal variable for a function. -
-
makeGlobalVar [Cil]
-Make a global variable. -
-
makeLocalVar [Cil]
-Make a local variable and add it to a function's slocals (only if insert = - true, which is the default). -
-
makeTempVar [Cil]
-Make a temporary variable and add it to a function's slocals. -
-
makeVarinfo [Cil]
-Make a varinfo. -
-
makeZeroInit [Cil]
-Make a initializer for zero-ing a data type -
-
map [Clist]
-Map a function over a clist. -
-
mapGlobals [Cil]
-Map over all globals, including the global initializer and change things - in place -
-
mapNoCopy [Cil]
-Like map but try not to make a copy of the list -
-
mapNoCopyList [Cil]
-Like map but each call can return a list. -
-
mark [Pretty]
-Mark the beginning of a markup section. -
-
markup [Pretty]
-Prints a document as markup. -
-
missingFieldName [Cil]
-This is a constant used as the name of an unnamed bitfield. -
-
mkAddrOf [Cil]
-Make an AddrOf. -
-
mkAddrOrStartOf [Cil]
-Like mkAddrOf except if the type of lval is an array then it uses - StartOf. -
-
mkBlock [Cil]
-Construct a block with no attributes, given a list of statements -
-
mkCast [Cil]
-Like Cil.mkCastT but uses typeOf to get oldt -
-
mkCastT [Cil]
-Construct a cast when having the old type of the expression. -
-
mkCompInfo [Cil]
-Creates a a (potentially recursive) composite type. -
-
mkEmptyStmt [Cil]
-Returns an empty statement (of kind Instr) -
-
mkFor [Cil]
-Make a for loop for(start; guard; next) { ... -
-
mkForIncr [Cil]
-Make a for loop for(i=start; i<past; i += incr) { ... -
-
mkMem [Cil]
-Make a Mem, while optimizing AddrOf. -
-
mkStmt [Cil]
-Construct a statement, given its kind. -
-
mkStmtOneInstr [Cil]
-Construct a statement consisting of just one instruction -
-
mkString [Cil]
-Make an expression that is a string constant (of pointer type) -
-
mkWhile [Cil]
-Make a while loop. -
-
mone [Cil]
--1 -
-
msvcBuiltins [Cil]
-A list of the MSVC built-in functions. -
-
msvcMode [Cil]
-Whether the pretty printer should print output for the MS VC compiler. -
-

N
name [Dataflow.BackwardsTransfer]
-For debugging purposes, the name of the analysis -
-
name [Dataflow.ForwardsTransfer]
-For debugging purposes, the name of the analysis -
-
newAlphaName [Alpha]
-Create a new name based on a given name. -
-
newHline [Errormsg]
newVID [Cil]
-Generate a new variable ID. -
-
new_sid [Cil]
newline [Errormsg]
nil [Pretty]
-Constructs an empty document -
-
noMemoize [Formatcil]
-If set then will not memoize the parsed patterns -
-
nodeList [Cfg]
-All of the nodes in a file. -
-
null [Errormsg]
-Do not actually print (i.e. -
-
num [Pretty]
-A document that prints an integer in decimal form -
-
numNodes [Cfg]
-number of nodes in the CFG -
-

O
one [Cil]
-1 -
-

P
parseInt [Cil]
-Convert a string representing a C integer literal to an expression. -
-
parse_error [Errormsg]
partitionAttributes [Cil]
-Partition the attributes into classes:name attributes, function type, - and type attributes -
-
peepHole1 [Cil]
-Similar to peepHole2 except that the optimization window consists of - one statement, not two -
-
peepHole2 [Cil]
-A peephole optimizer that processes two adjacent statements and possibly - replaces them both. -
-
plainCilPrinter [Cil]
popContext [Errormsg]
-Removes the last registered context printing function -
-
prepareCFG [Cil]
-Prepare a function for CFG information computation by - Cil.computeCFGInfo. -
-
pretty [Dataflow.BackwardsTransfer]
-Pretty-print the state -
-
pretty [Dataflow.ForwardsTransfer]
-Pretty-print the state -
-
print [Stats]
-Print the current stats preceeded by a message -
-
printAttr [Cil]
-Print an attribute given a pretty printer -
-
printAttrs [Cil]
-Print a set of attributes given a pretty printer -
-
printBlock [Cil]
-Print a block given a pretty printer. -
-
printCfgChannel [Cfg]
-print control flow graph (in dot form) for fundec to channel -
-
printCfgFilename [Cfg]
-Print control flow graph (in dot form) for fundec to file -
-
printCilAsIs [Cil]
-Whether to print the CIL as they are, without trying to be smart and - print nicer code. -
-
printDepth [Pretty]
-Specifies the nesting depth of the align/unalign pairs at which - everything is replaced with ellipsis -
-
printExp [Cil]
-Print an expression given a pretty printer -
-
printGlobal [Cil]
-Print a global given a pretty printer -
-
printIndent [Pretty]
-If false then does not indent -
-
printInit [Cil]
-Print an initializer given a pretty printer. -
-
printInstr [Cil]
-Print an instruction given a pretty printer -
-
printLval [Cil]
-Print an lvalue given a pretty printer -
-
printStmt [Cil]
-Print a statement given a pretty printer. -
-
printType [Cil]
-Print a type given a pretty printer -
-
print_CIL_Input [Cil]
-Whether we print something that will only be used as input to our own - parser. -
-
printerForMaincil [Cil]
printf [Pretty]
-Like Pretty.fprintf applied to stdout -
-
pushContext [Errormsg]
-Registers a context printing function -
-
pushGlobal [Cil]
-CIL keeps the types at the beginning of the file and the variables at the - end of the file. -
-

R
readingFromStdin [Errormsg]
-Records whether the stdin is open for reading the goal * -
-
real [Pretty]
-A document that prints a real number -
-
registerAlphaName [Alpha]
-Register a name with an alpha conversion table to ensure that when later - we call newAlphaName we do not end up generating this one -
-
removeOffset [Cil]
-Remove ONE offset from the end of an offset sequence. -
-
removeOffsetLval [Cil]
-Remove ONE offset from the end of an lvalue. -
-
repeattime [Stats]
-repeattime is like time but runs the function several times until the total - running time is greater or equal to the first argument. -
-
reset [Stats]
-Resets all the timings. -
-
rev [Clist]
-Reverse a clist. -
-

S
s [Errormsg]
-Stop the execution by raising an Error. -
-
sample_pentium_perfcount_10 [Stats]
-Sample the current cycle count, in kilocycles. -
-
sample_pentium_perfcount_20 [Stats]
-Sample the current cycle count, in megacycles. -
-
saveBinaryFile [Cil]
-Write a Cil.file in binary form to the filesystem. -
-
saveBinaryFileChannel [Cil]
-Write a Cil.file in binary form to the filesystem. -
-
separateStorageModifiers [Cil]
-Separate out the storage-modifier name attributes -
-
seq [Pretty]
-Formats a sequence. -
-
setCurrentFile [Errormsg]
setCurrentLine [Errormsg]
setFormals [Cil]
-Update the formals of a fundec and make sure that the function type - has the same information. -
-
setFunctionType [Cil]
-Set the types of arguments and results as given by the function type - passed as the second argument. -
-
setFunctionTypeMakeFormals [Cil]
-Set the type of the function and make formal arguments for them -
-
setHFile [Errormsg]
setHLine [Errormsg]
setMaxId [Cil]
-Update the smaxid after you have populated with locals and formals - (unless you constructed those using Cil.makeLocalVar or - Cil.makeTempVar. -
-
setTypeAttrs [Cil]
setTypeSigAttrs [Cil]
-Replace the attributes of a signature (only at top level) -
-
showContext [Errormsg]
-Show the context stack to stderr -
-
single [Clist]
-Create a clist containing one element -
-
sizeOf [Cil]
splitFunctionType [Cil]
-Given a function type split it into return type, - arguments, is_vararg and attributes. -
-
splitFunctionTypeVI [Cil]
sprint [Pretty]
-Format the document to the given width and emit it as a string -
-
startParsing [Errormsg]
startParsingFromString [Errormsg]
start_id [Cfg]
-Next statement id that will be assigned. -
-
startsWith [Cil]
-sm: return true if the first is a prefix of the second string -
-
stmtStartData [Dataflow.BackwardsTransfer]
-For each block id, the data at the start. -
-
stmtStartData [Dataflow.ForwardsTransfer]
-For each statement id, the data at the start. -
-
stripCasts [Cil]
-Removes casts from this expression, but ignores casts within - other expression constructs. -
-

T
test [Formatcil]
-Just a testing function -
-
text [Pretty]
-A document that prints the given string -
-
time [Stats]
-Time a function and associate the time with the given string. -
-
timethis [Stats]
toList [Clist]
-Convert a clist to an ordinary list -
-
typeAddAttributes [Cil]
-Add some attributes to a type -
-
typeAttrs [Cil]
-Returns all the attributes contained in a type. -
-
typeOf [Cil]
-Compute the type of an expression -
-
typeOfLval [Cil]
-Compute the type of an lvalue -
-
typeOfSizeOf [Cil]
typeOffset [Cil]
-Compute the type of an offset from a base type -
-
typeRemoveAttributes [Cil]
-Remove all attributes with the given names from a type. -
-
typeSig [Cil]
-Compute a type signature -
-
typeSigAttrs [Cil]
-Get the top-level attributes of a signature -
-
typeSigWithAttrs [Cil]
-Like Cil.typeSig but customize the incorporation of attributes. -
-

U
uintPtrType [Cil]
-unsigned int * -
-
uintType [Cil]
-unsigned int -
-
ulongType [Cil]
-unsigned long -
-
unalign [Pretty]
-Reverts to the last saved indentation level. -
-
underscore_name [Cil]
-Whether the compiler generates assembly labels by prepending "_" to the - identifier. -
-
undoAlphaChanges [Alpha]
-Undo the changes to a table -
-
unimp [Cil]
-Like Errormsg.unimp except that Cil.currentLocis also printed -
-
unimp [Errormsg]
-Similar to error except that its output has the form Unimplemented: ... -
-
uniqueVarNames [Cil]
-Assign unique names to local variables. -
-
unmark [Pretty]
-The end of a markup section -
-
unrollType [Cil]
-Unroll a type until it exposes a non - TNamed. -
-
unrollTypeDeep [Cil]
-Unroll all the TNamed in a type (even under type constructors such as - TPtr, TFun or TArray. -
-
upointType [Cil]
useLogicalOperators [Cil]
-Whether to use the logical operands LAnd and LOr. -
-

V
var [Cil]
-Makes an lvalue out of a given variable -
-
verboseFlag [Errormsg]
visitCilAttributes [Cil]
-Visit a list of attributes -
-
visitCilBlock [Cil]
-Visit a block -
-
visitCilExpr [Cil]
visitCilFile [Cil]
-Visit a file. -
-
visitCilFileSameGlobals [Cil]
-A visitor for the whole file that does not change the globals (but maybe - changes things inside the globals). -
-
visitCilFunction [Cil]
-Visit a function definition -
-
visitCilGlobal [Cil]
-Visit a global -
-
visitCilInit [Cil]
-Visit an initializer -
-
visitCilInitOffset [Cil]
-Visit an initializer offset -
-
visitCilInstr [Cil]
-Visit an instruction -
-
visitCilLval [Cil]
-Visit an lvalue -
-
visitCilOffset [Cil]
-Visit an lvalue or recursive offset -
-
visitCilStmt [Cil]
-Visit a statement -
-
visitCilType [Cil]
-Visit a type -
-
visitCilVarDecl [Cil]
-Visit a variable declaration -
-
voidPtrType [Cil]
-void * -
-
voidType [Cil]
-void -
-

W
warn [Cil]
-Like Errormsg.warn except that Cil.currentLoc is also printed -
-
warn [Errormsg]
-Like Errormsg.error but does not raise the Errormsg.Error - exception. -
-
warnContext [Cil]
-Like Errormsg.warn except that Cil.currentLoc and context - is also printed -
-
warnContextOpt [Cil]
-Like Errormsg.warn except that Cil.currentLoc and context is also - printed. -
-
warnFlag [Errormsg]
-Set to true if you want to see all warnings. -
-
warnLoc [Cil]
-Like Cil.warn except that it explicitly takes a location argument, - instead of using the Cil.currentLoc -
-
warnOpt [Cil]
-Like Errormsg.warnOpt except that Cil.currentLoc is also printed. -
-
warnOpt [Errormsg]
-Like Errormsg.warn but optional. -
-
wcharKind [Cil]
-wchar_t (depends on architecture) and is set when you call - Cil.initCIL. -
-
wcharType [Cil]
withContext [Errormsg]
-To ensure that the context is registered and removed properly, use the - function below -
-
withPrintDepth [Pretty]
-Invokes a thunk, with printDepth temporarily set to the specified value -
-

Z
zero [Cil]
-0 -
-

- - \ No newline at end of file diff --git a/cil/doc/api/style.css b/cil/doc/api/style.css deleted file mode 100644 index 11ed40c..0000000 --- a/cil/doc/api/style.css +++ /dev/null @@ -1,32 +0,0 @@ -a:visited {color : #416DFF; text-decoration : none; } -a:link {color : #416DFF; text-decoration : none;} -a:hover {color : Red; text-decoration : none; background-color: #5FFF88} -a:active {color : Red; text-decoration : underline; } -.keyword { font-weight : bold ; color : Red } -.keywordsign { color : #C04600 } -.superscript { font-size : 4 } -.subscript { font-size : 4 } -.comment { color : Green } -.constructor { color : Blue } -.type { color : #5C6585 } -.string { color : Maroon } -.warning { color : Red ; font-weight : bold } -.info { margin-left : 3em; margin-right : 3em } -.code { color : #465F91 ; } -h1 { font-size : 20pt ; text-align: center; } -h2 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ;padding: 2px; } -h3 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90DDFF ;padding: 2px; } -h4 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90EDFF ;padding: 2px; } -h5 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90FDFF ;padding: 2px; } -h6 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #C0FFFF ; padding: 2px; } -div.h7 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #E0FFFF ; padding: 2px; } -div.h8 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #F0FFFF ; padding: 2px; } -div.h9 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #FFFFFF ; padding: 2px; } -.typetable { border-style : hidden } -.indextable { border-style : hidden } -.paramstable { border-style : hidden ; padding: 5pt 5pt} -body { background-color : White } -tr { background-color : White } -td.typefieldcomment { background-color : #FFFFFF } -pre { margin-bottom: 4px } -div.sig_block {margin-left: 2em} \ No newline at end of file diff --git a/cil/doc/api/type_Alpha.html b/cil/doc/api/type_Alpha.html deleted file mode 100644 index b97c835..0000000 --- a/cil/doc/api/type_Alpha.html +++ /dev/null @@ -1,43 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Alpha - - -sig
-  type 'a undoAlphaElement
-  type 'a alphaTableData
-  val newAlphaName :
-    alphaTable:(string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t ->
-    undolist:'a Alpha.undoAlphaElement list Pervasives.ref option ->
-    lookupname:string -> data:'a -> string * 'a
-  val registerAlphaName :
-    alphaTable:(string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t ->
-    undolist:'a Alpha.undoAlphaElement list Pervasives.ref option ->
-    lookupname:string -> data:'a -> unit
-  val docAlphaTable :
-    unit ->
-    (string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t -> Pretty.doc
-  val getAlphaPrefix : lookupname:string -> string
-  val undoAlphaChanges :
-    alphaTable:(string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t ->
-    undolist:'a Alpha.undoAlphaElement list -> unit
-end \ No newline at end of file diff --git a/cil/doc/api/type_Cfg.html b/cil/doc/api/type_Cfg.html deleted file mode 100644 index 996d773..0000000 --- a/cil/doc/api/type_Cfg.html +++ /dev/null @@ -1,35 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cfg - - -sig
-  val computeFileCFG : Cil.file -> unit
-  val clearFileCFG : Cil.file -> unit
-  val cfgFun : Cil.fundec -> int
-  val clearCFGinfo : Cil.fundec -> unit
-  val printCfgChannel : Pervasives.out_channel -> Cil.fundec -> unit
-  val printCfgFilename : string -> Cil.fundec -> unit
-  val start_id : int Pervasives.ref
-  val nodeList : Cil.stmt list Pervasives.ref
-  val numNodes : int Pervasives.ref
-end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.cilPrinter.html b/cil/doc/api/type_Cil.cilPrinter.html deleted file mode 100644 index ff117f5..0000000 --- a/cil/doc/api/type_Cil.cilPrinter.html +++ /dev/null @@ -1,48 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.cilPrinter - - -object
-  method dBlock : Pervasives.out_channel -> int -> Cil.block -> unit
-  method dGlobal : Pervasives.out_channel -> Cil.global -> unit
-  method dInit : Pervasives.out_channel -> int -> Cil.init -> unit
-  method dStmt : Pervasives.out_channel -> int -> Cil.stmt -> unit
-  method pAttr : Cil.attribute -> Pretty.doc * bool
-  method pAttrParam : unit -> Cil.attrparam -> Pretty.doc
-  method pAttrs : unit -> Cil.attributes -> Pretty.doc
-  method pBlock : unit -> Cil.block -> Pretty.doc
-  method pExp : unit -> Cil.exp -> Pretty.doc
-  method pFieldDecl : unit -> Cil.fieldinfo -> Pretty.doc
-  method pGlobal : unit -> Cil.global -> Pretty.doc
-  method pInit : unit -> Cil.init -> Pretty.doc
-  method pInstr : unit -> Cil.instr -> Pretty.doc
-  method pLabel : unit -> Cil.label -> Pretty.doc
-  method pLineDirective : ?forcefile:bool -> Cil.location -> Pretty.doc
-  method pLval : unit -> Cil.lval -> Pretty.doc
-  method pOffset : Pretty.doc -> Cil.offset -> Pretty.doc
-  method pStmt : unit -> Cil.stmt -> Pretty.doc
-  method pStmtKind : Cil.stmt -> unit -> Cil.stmtkind -> Pretty.doc
-  method pType : Pretty.doc option -> unit -> Cil.typ -> Pretty.doc
-  method pVDecl : unit -> Cil.varinfo -> Pretty.doc
-  method pVar : Cil.varinfo -> Pretty.doc
-end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.cilVisitor.html b/cil/doc/api/type_Cil.cilVisitor.html deleted file mode 100644 index efe3d13..0000000 --- a/cil/doc/api/type_Cil.cilVisitor.html +++ /dev/null @@ -1,43 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.cilVisitor - - -object
-  method queueInstr : Cil.instr list -> unit
-  method unqueueInstr : unit -> Cil.instr list
-  method vattr : Cil.attribute -> Cil.attribute list Cil.visitAction
-  method vattrparam : Cil.attrparam -> Cil.attrparam Cil.visitAction
-  method vblock : Cil.block -> Cil.block Cil.visitAction
-  method vexpr : Cil.exp -> Cil.exp Cil.visitAction
-  method vfunc : Cil.fundec -> Cil.fundec Cil.visitAction
-  method vglob : Cil.global -> Cil.global list Cil.visitAction
-  method vinit : Cil.init -> Cil.init Cil.visitAction
-  method vinitoffs : Cil.offset -> Cil.offset Cil.visitAction
-  method vinst : Cil.instr -> Cil.instr list Cil.visitAction
-  method vlval : Cil.lval -> Cil.lval Cil.visitAction
-  method voffs : Cil.offset -> Cil.offset Cil.visitAction
-  method vstmt : Cil.stmt -> Cil.stmt Cil.visitAction
-  method vtype : Cil.typ -> Cil.typ Cil.visitAction
-  method vvdec : Cil.varinfo -> Cil.varinfo Cil.visitAction
-  method vvrbl : Cil.varinfo -> Cil.varinfo Cil.visitAction
-end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.defaultCilPrinterClass.html b/cil/doc/api/type_Cil.defaultCilPrinterClass.html deleted file mode 100644 index 75a36eb..0000000 --- a/cil/doc/api/type_Cil.defaultCilPrinterClass.html +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.defaultCilPrinterClass - - -Cil.cilPrinter \ No newline at end of file diff --git a/cil/doc/api/type_Cil.html b/cil/doc/api/type_Cil.html deleted file mode 100644 index da6f9e9..0000000 --- a/cil/doc/api/type_Cil.html +++ /dev/null @@ -1,622 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil - - -sig
-  val initCIL : unit -> unit
-  val cilVersion : string
-  val cilVersionMajor : int
-  val cilVersionMinor : int
-  val cilVersionRevision : int
-  type file = {
-    mutable fileName : string;
-    mutable globals : Cil.global list;
-    mutable globinit : Cil.fundec option;
-    mutable globinitcalled : bool;
-  }
-  and comment = Cil.location * string
-  and global =
-      GType of Cil.typeinfo * Cil.location
-    | GCompTag of Cil.compinfo * Cil.location
-    | GCompTagDecl of Cil.compinfo * Cil.location
-    | GEnumTag of Cil.enuminfo * Cil.location
-    | GEnumTagDecl of Cil.enuminfo * Cil.location
-    | GVarDecl of Cil.varinfo * Cil.location
-    | GVar of Cil.varinfo * Cil.initinfo * Cil.location
-    | GFun of Cil.fundec * Cil.location
-    | GAsm of string * Cil.location
-    | GPragma of Cil.attribute * Cil.location
-    | GText of string
-  and typ =
-      TVoid of Cil.attributes
-    | TInt of Cil.ikind * Cil.attributes
-    | TFloat of Cil.fkind * Cil.attributes
-    | TPtr of Cil.typ * Cil.attributes
-    | TArray of Cil.typ * Cil.exp option * Cil.attributes
-    | TFun of Cil.typ * (string * Cil.typ * Cil.attributes) list option *
-        bool * Cil.attributes
-    | TNamed of Cil.typeinfo * Cil.attributes
-    | TComp of Cil.compinfo * Cil.attributes
-    | TEnum of Cil.enuminfo * Cil.attributes
-    | TBuiltin_va_list of Cil.attributes
-  and ikind =
-      IChar
-    | ISChar
-    | IUChar
-    | IInt
-    | IUInt
-    | IShort
-    | IUShort
-    | ILong
-    | IULong
-    | ILongLong
-    | IULongLong
-  and fkind = FFloat | FDouble | FLongDouble
-  and attribute = Attr of string * Cil.attrparam list
-  and attributes = Cil.attribute list
-  and attrparam =
-      AInt of int
-    | AStr of string
-    | ACons of string * Cil.attrparam list
-    | ASizeOf of Cil.typ
-    | ASizeOfE of Cil.attrparam
-    | ASizeOfS of Cil.typsig
-    | AAlignOf of Cil.typ
-    | AAlignOfE of Cil.attrparam
-    | AAlignOfS of Cil.typsig
-    | AUnOp of Cil.unop * Cil.attrparam
-    | ABinOp of Cil.binop * Cil.attrparam * Cil.attrparam
-    | ADot of Cil.attrparam * string
-  and compinfo = {
-    mutable cstruct : bool;
-    mutable cname : string;
-    mutable ckey : int;
-    mutable cfields : Cil.fieldinfo list;
-    mutable cattr : Cil.attributes;
-    mutable cdefined : bool;
-    mutable creferenced : bool;
-  }
-  and fieldinfo = {
-    mutable fcomp : Cil.compinfo;
-    mutable fname : string;
-    mutable ftype : Cil.typ;
-    mutable fbitfield : int option;
-    mutable fattr : Cil.attributes;
-    mutable floc : Cil.location;
-  }
-  and enuminfo = {
-    mutable ename : string;
-    mutable eitems : (string * Cil.exp * Cil.location) list;
-    mutable eattr : Cil.attributes;
-    mutable ereferenced : bool;
-  }
-  and typeinfo = {
-    mutable tname : string;
-    mutable ttype : Cil.typ;
-    mutable treferenced : bool;
-  }
-  and varinfo = {
-    mutable vname : string;
-    mutable vtype : Cil.typ;
-    mutable vattr : Cil.attributes;
-    mutable vstorage : Cil.storage;
-    mutable vglob : bool;
-    mutable vinline : bool;
-    mutable vdecl : Cil.location;
-    mutable vid : int;
-    mutable vaddrof : bool;
-    mutable vreferenced : bool;
-  }
-  and storage = NoStorage | Static | Register | Extern
-  and exp =
-      Const of Cil.constant
-    | Lval of Cil.lval
-    | SizeOf of Cil.typ
-    | SizeOfE of Cil.exp
-    | SizeOfStr of string
-    | AlignOf of Cil.typ
-    | AlignOfE of Cil.exp
-    | UnOp of Cil.unop * Cil.exp * Cil.typ
-    | BinOp of Cil.binop * Cil.exp * Cil.exp * Cil.typ
-    | CastE of Cil.typ * Cil.exp
-    | AddrOf of Cil.lval
-    | StartOf of Cil.lval
-  and constant =
-      CInt64 of int64 * Cil.ikind * string option
-    | CStr of string
-    | CWStr of int64 list
-    | CChr of char
-    | CReal of float * Cil.fkind * string option
-    | CEnum of Cil.exp * string * Cil.enuminfo
-  and unop = Neg | BNot | LNot
-  and binop =
-      PlusA
-    | PlusPI
-    | IndexPI
-    | MinusA
-    | MinusPI
-    | MinusPP
-    | Mult
-    | Div
-    | Mod
-    | Shiftlt
-    | Shiftrt
-    | Lt
-    | Gt
-    | Le
-    | Ge
-    | Eq
-    | Ne
-    | BAnd
-    | BXor
-    | BOr
-    | LAnd
-    | LOr
-  and lval = Cil.lhost * Cil.offset
-  and lhost = Var of Cil.varinfo | Mem of Cil.exp
-  and offset =
-      NoOffset
-    | Field of Cil.fieldinfo * Cil.offset
-    | Index of Cil.exp * Cil.offset
-  and init =
-      SingleInit of Cil.exp
-    | CompoundInit of Cil.typ * (Cil.offset * Cil.init) list
-  and initinfo = { mutable init : Cil.init option; }
-  and fundec = {
-    mutable svar : Cil.varinfo;
-    mutable sformals : Cil.varinfo list;
-    mutable slocals : Cil.varinfo list;
-    mutable smaxid : int;
-    mutable sbody : Cil.block;
-    mutable smaxstmtid : int option;
-    mutable sallstmts : Cil.stmt list;
-  }
-  and block = {
-    mutable battrs : Cil.attributes;
-    mutable bstmts : Cil.stmt list;
-  }
-  and stmt = {
-    mutable labels : Cil.label list;
-    mutable skind : Cil.stmtkind;
-    mutable sid : int;
-    mutable succs : Cil.stmt list;
-    mutable preds : Cil.stmt list;
-  }
-  and label =
-      Label of string * Cil.location * bool
-    | Case of Cil.exp * Cil.location
-    | Default of Cil.location
-  and stmtkind =
-      Instr of Cil.instr list
-    | Return of Cil.exp option * Cil.location
-    | Goto of Cil.stmt Pervasives.ref * Cil.location
-    | Break of Cil.location
-    | Continue of Cil.location
-    | If of Cil.exp * Cil.block * Cil.block * Cil.location
-    | Switch of Cil.exp * Cil.block * Cil.stmt list * Cil.location
-    | Loop of Cil.block * Cil.location * Cil.stmt option * Cil.stmt option
-    | Block of Cil.block
-    | TryFinally of Cil.block * Cil.block * Cil.location
-    | TryExcept of Cil.block * (Cil.instr list * Cil.exp) * Cil.block *
-        Cil.location
-  and instr =
-      Set of Cil.lval * Cil.exp * Cil.location
-    | Call of Cil.lval option * Cil.exp * Cil.exp list * Cil.location
-    | Asm of Cil.attributes * string list * (string * Cil.lval) list *
-        (string * Cil.exp) list * string list * Cil.location
-  and location = { line : int; file : string; byte : int; }
-  and typsig =
-      TSArray of Cil.typsig * int64 option * Cil.attribute list
-    | TSPtr of Cil.typsig * Cil.attribute list
-    | TSComp of bool * string * Cil.attribute list
-    | TSFun of Cil.typsig * Cil.typsig list * bool * Cil.attribute list
-    | TSEnum of string * Cil.attribute list
-    | TSBase of Cil.typ
-  val lowerConstants : bool ref
-  val insertImplicitCasts : bool Pervasives.ref
-  type featureDescr = {
-    fd_enabled : bool Pervasives.ref;
-    fd_name : string;
-    fd_description : string;
-    fd_extraopt : (string * Arg.spec * string) list;
-    fd_doit : Cil.file -> unit;
-    fd_post_check : bool;
-  }
-  val compareLoc : Cil.location -> Cil.location -> int
-  val emptyFunction : string -> Cil.fundec
-  val setFormals : Cil.fundec -> Cil.varinfo list -> unit
-  val setFunctionType : Cil.fundec -> Cil.typ -> unit
-  val setFunctionTypeMakeFormals : Cil.fundec -> Cil.typ -> unit
-  val setMaxId : Cil.fundec -> unit
-  val dummyFunDec : Cil.fundec
-  val dummyFile : Cil.file
-  val saveBinaryFile : Cil.file -> string -> unit
-  val saveBinaryFileChannel : Cil.file -> Pervasives.out_channel -> unit
-  val loadBinaryFile : string -> Cil.file
-  val getGlobInit : ?main_name:string -> Cil.file -> Cil.fundec
-  val iterGlobals : Cil.file -> (Cil.global -> unit) -> unit
-  val foldGlobals : Cil.file -> ('a -> Cil.global -> 'a) -> 'a -> 'a
-  val mapGlobals : Cil.file -> (Cil.global -> Cil.global) -> unit
-  val new_sid : unit -> int
-  val prepareCFG : Cil.fundec -> unit
-  val computeCFGInfo : Cil.fundec -> bool -> unit
-  val copyFunction : Cil.fundec -> string -> Cil.fundec
-  val pushGlobal :
-    Cil.global ->
-    types:Cil.global list Pervasives.ref ->
-    variables:Cil.global list Pervasives.ref -> unit
-  val invalidStmt : Cil.stmt
-  val gccBuiltins : (string, Cil.typ * Cil.typ list * bool) Hashtbl.t
-  val msvcBuiltins : (string, Cil.typ * Cil.typ list * bool) Hashtbl.t
-  val makeZeroInit : Cil.typ -> Cil.init
-  val foldLeftCompound :
-    doinit:(Cil.offset -> Cil.init -> Cil.typ -> 'a -> 'a) ->
-    ct:Cil.typ -> initl:(Cil.offset * Cil.init) list -> acc:'a -> 'a
-  val foldLeftCompoundAll :
-    doinit:(Cil.offset -> Cil.init -> Cil.typ -> 'a -> 'a) ->
-    ct:Cil.typ -> initl:(Cil.offset * Cil.init) list -> acc:'a -> 'a
-  val voidType : Cil.typ
-  val isVoidType : Cil.typ -> bool
-  val isVoidPtrType : Cil.typ -> bool
-  val intType : Cil.typ
-  val uintType : Cil.typ
-  val longType : Cil.typ
-  val ulongType : Cil.typ
-  val charType : Cil.typ
-  val charPtrType : Cil.typ
-  val wcharKind : Cil.ikind Pervasives.ref
-  val wcharType : Cil.typ Pervasives.ref
-  val charConstPtrType : Cil.typ
-  val voidPtrType : Cil.typ
-  val intPtrType : Cil.typ
-  val uintPtrType : Cil.typ
-  val doubleType : Cil.typ
-  val upointType : Cil.typ Pervasives.ref
-  val typeOfSizeOf : Cil.typ Pervasives.ref
-  val isSigned : Cil.ikind -> bool
-  val mkCompInfo :
-    bool ->
-    string ->
-    (Cil.compinfo ->
-     (string * Cil.typ * int option * Cil.attributes * Cil.location) list) ->
-    Cil.attributes -> Cil.compinfo
-  val copyCompInfo : Cil.compinfo -> string -> Cil.compinfo
-  val missingFieldName : string
-  val compFullName : Cil.compinfo -> string
-  val isCompleteType : Cil.typ -> bool
-  val unrollType : Cil.typ -> Cil.typ
-  val unrollTypeDeep : Cil.typ -> Cil.typ
-  val separateStorageModifiers :
-    Cil.attribute list -> Cil.attribute list * Cil.attribute list
-  val isIntegralType : Cil.typ -> bool
-  val isArithmeticType : Cil.typ -> bool
-  val isPointerType : Cil.typ -> bool
-  val isFunctionType : Cil.typ -> bool
-  val argsToList :
-    (string * Cil.typ * Cil.attributes) list option ->
-    (string * Cil.typ * Cil.attributes) list
-  val isArrayType : Cil.typ -> bool
-  exception LenOfArray
-  val lenOfArray : Cil.exp option -> int
-  val getCompField : Cil.compinfo -> string -> Cil.fieldinfo
-  type existsAction = ExistsTrue | ExistsFalse | ExistsMaybe
-  val existsType : (Cil.typ -> Cil.existsAction) -> Cil.typ -> bool
-  val splitFunctionType :
-    Cil.typ ->
-    Cil.typ * (string * Cil.typ * Cil.attributes) list option * bool *
-    Cil.attributes
-  val splitFunctionTypeVI :
-    Cil.varinfo ->
-    Cil.typ * (string * Cil.typ * Cil.attributes) list option * bool *
-    Cil.attributes
-  val d_typsig : unit -> Cil.typsig -> Pretty.doc
-  val typeSig : Cil.typ -> Cil.typsig
-  val typeSigWithAttrs :
-    ?ignoreSign:bool ->
-    (Cil.attributes -> Cil.attributes) -> Cil.typ -> Cil.typsig
-  val setTypeSigAttrs : Cil.attributes -> Cil.typsig -> Cil.typsig
-  val typeSigAttrs : Cil.typsig -> Cil.attributes
-  val makeVarinfo : bool -> string -> Cil.typ -> Cil.varinfo
-  val makeFormalVar :
-    Cil.fundec -> ?where:string -> string -> Cil.typ -> Cil.varinfo
-  val makeLocalVar :
-    Cil.fundec -> ?insert:bool -> string -> Cil.typ -> Cil.varinfo
-  val makeTempVar : Cil.fundec -> ?name:string -> Cil.typ -> Cil.varinfo
-  val makeGlobalVar : string -> Cil.typ -> Cil.varinfo
-  val copyVarinfo : Cil.varinfo -> string -> Cil.varinfo
-  val newVID : unit -> int
-  val addOffsetLval : Cil.offset -> Cil.lval -> Cil.lval
-  val addOffset : Cil.offset -> Cil.offset -> Cil.offset
-  val removeOffsetLval : Cil.lval -> Cil.lval * Cil.offset
-  val removeOffset : Cil.offset -> Cil.offset * Cil.offset
-  val typeOfLval : Cil.lval -> Cil.typ
-  val typeOffset : Cil.typ -> Cil.offset -> Cil.typ
-  val zero : Cil.exp
-  val one : Cil.exp
-  val mone : Cil.exp
-  val kinteger64 : Cil.ikind -> int64 -> Cil.exp
-  val kinteger : Cil.ikind -> int -> Cil.exp
-  val integer : int -> Cil.exp
-  val isInteger : Cil.exp -> int64 option
-  val isConstant : Cil.exp -> bool
-  val isZero : Cil.exp -> bool
-  val charConstToInt : char -> Cil.constant
-  val constFold : bool -> Cil.exp -> Cil.exp
-  val constFoldBinOp :
-    bool -> Cil.binop -> Cil.exp -> Cil.exp -> Cil.typ -> Cil.exp
-  val increm : Cil.exp -> int -> Cil.exp
-  val var : Cil.varinfo -> Cil.lval
-  val mkAddrOf : Cil.lval -> Cil.exp
-  val mkAddrOrStartOf : Cil.lval -> Cil.exp
-  val mkMem : addr:Cil.exp -> off:Cil.offset -> Cil.lval
-  val mkString : string -> Cil.exp
-  val mkCastT : e:Cil.exp -> oldt:Cil.typ -> newt:Cil.typ -> Cil.exp
-  val mkCast : e:Cil.exp -> newt:Cil.typ -> Cil.exp
-  val stripCasts : Cil.exp -> Cil.exp
-  val typeOf : Cil.exp -> Cil.typ
-  val parseInt : string -> Cil.exp
-  val mkStmt : Cil.stmtkind -> Cil.stmt
-  val mkBlock : Cil.stmt list -> Cil.block
-  val mkStmtOneInstr : Cil.instr -> Cil.stmt
-  val compactStmts : Cil.stmt list -> Cil.stmt list
-  val mkEmptyStmt : unit -> Cil.stmt
-  val dummyInstr : Cil.instr
-  val dummyStmt : Cil.stmt
-  val mkWhile : guard:Cil.exp -> body:Cil.stmt list -> Cil.stmt list
-  val mkForIncr :
-    iter:Cil.varinfo ->
-    first:Cil.exp ->
-    stopat:Cil.exp -> incr:Cil.exp -> body:Cil.stmt list -> Cil.stmt list
-  val mkFor :
-    start:Cil.stmt list ->
-    guard:Cil.exp ->
-    next:Cil.stmt list -> body:Cil.stmt list -> Cil.stmt list
-  type attributeClass = AttrName of bool | AttrFunType of bool | AttrType
-  val attributeHash : (string, Cil.attributeClass) Hashtbl.t
-  val partitionAttributes :
-    default:Cil.attributeClass ->
-    Cil.attributes ->
-    Cil.attribute list * Cil.attribute list * Cil.attribute list
-  val addAttribute : Cil.attribute -> Cil.attributes -> Cil.attributes
-  val addAttributes : Cil.attribute list -> Cil.attributes -> Cil.attributes
-  val dropAttribute : string -> Cil.attributes -> Cil.attributes
-  val dropAttributes : string list -> Cil.attributes -> Cil.attributes
-  val filterAttributes : string -> Cil.attributes -> Cil.attributes
-  val hasAttribute : string -> Cil.attributes -> bool
-  val typeAttrs : Cil.typ -> Cil.attribute list
-  val setTypeAttrs : Cil.typ -> Cil.attributes -> Cil.typ
-  val typeAddAttributes : Cil.attribute list -> Cil.typ -> Cil.typ
-  val typeRemoveAttributes : string list -> Cil.typ -> Cil.typ
-  type 'a visitAction =
-      SkipChildren
-    | DoChildren
-    | ChangeTo of 'a
-    | ChangeDoChildrenPost of 'a * ('a -> 'a)
-  class type cilVisitor =
-    object
-      method queueInstr : Cil.instr list -> unit
-      method unqueueInstr : unit -> Cil.instr list
-      method vattr : Cil.attribute -> Cil.attribute list Cil.visitAction
-      method vattrparam : Cil.attrparam -> Cil.attrparam Cil.visitAction
-      method vblock : Cil.block -> Cil.block Cil.visitAction
-      method vexpr : Cil.exp -> Cil.exp Cil.visitAction
-      method vfunc : Cil.fundec -> Cil.fundec Cil.visitAction
-      method vglob : Cil.global -> Cil.global list Cil.visitAction
-      method vinit : Cil.init -> Cil.init Cil.visitAction
-      method vinitoffs : Cil.offset -> Cil.offset Cil.visitAction
-      method vinst : Cil.instr -> Cil.instr list Cil.visitAction
-      method vlval : Cil.lval -> Cil.lval Cil.visitAction
-      method voffs : Cil.offset -> Cil.offset Cil.visitAction
-      method vstmt : Cil.stmt -> Cil.stmt Cil.visitAction
-      method vtype : Cil.typ -> Cil.typ Cil.visitAction
-      method vvdec : Cil.varinfo -> Cil.varinfo Cil.visitAction
-      method vvrbl : Cil.varinfo -> Cil.varinfo Cil.visitAction
-    end
-  class nopCilVisitor : cilVisitor
-  val visitCilFile : Cil.cilVisitor -> Cil.file -> unit
-  val visitCilFileSameGlobals : Cil.cilVisitor -> Cil.file -> unit
-  val visitCilGlobal : Cil.cilVisitor -> Cil.global -> Cil.global list
-  val visitCilFunction : Cil.cilVisitor -> Cil.fundec -> Cil.fundec
-  val visitCilExpr : Cil.cilVisitor -> Cil.exp -> Cil.exp
-  val visitCilLval : Cil.cilVisitor -> Cil.lval -> Cil.lval
-  val visitCilOffset : Cil.cilVisitor -> Cil.offset -> Cil.offset
-  val visitCilInitOffset : Cil.cilVisitor -> Cil.offset -> Cil.offset
-  val visitCilInstr : Cil.cilVisitor -> Cil.instr -> Cil.instr list
-  val visitCilStmt : Cil.cilVisitor -> Cil.stmt -> Cil.stmt
-  val visitCilBlock : Cil.cilVisitor -> Cil.block -> Cil.block
-  val visitCilType : Cil.cilVisitor -> Cil.typ -> Cil.typ
-  val visitCilVarDecl : Cil.cilVisitor -> Cil.varinfo -> Cil.varinfo
-  val visitCilInit : Cil.cilVisitor -> Cil.init -> Cil.init
-  val visitCilAttributes :
-    Cil.cilVisitor -> Cil.attribute list -> Cil.attribute list
-  val msvcMode : bool Pervasives.ref
-  val useLogicalOperators : bool Pervasives.ref
-  val constFoldVisitor : bool -> Cil.cilVisitor
-  type lineDirectiveStyle =
-      LineComment
-    | LinePreprocessorInput
-    | LinePreprocessorOutput
-  val lineDirectiveStyle : Cil.lineDirectiveStyle option Pervasives.ref
-  val print_CIL_Input : bool Pervasives.ref
-  val printCilAsIs : bool Pervasives.ref
-  val lineLength : int Pervasives.ref
-  val forgcc : string -> string
-  val currentLoc : Cil.location Pervasives.ref
-  val currentGlobal : Cil.global Pervasives.ref
-  val d_loc : unit -> Cil.location -> Pretty.doc
-  val d_thisloc : unit -> Pretty.doc
-  val d_ikind : unit -> Cil.ikind -> Pretty.doc
-  val d_fkind : unit -> Cil.fkind -> Pretty.doc
-  val d_storage : unit -> Cil.storage -> Pretty.doc
-  val d_const : unit -> Cil.constant -> Pretty.doc
-  val derefStarLevel : int
-  val indexLevel : int
-  val arrowLevel : int
-  val addrOfLevel : int
-  val additiveLevel : int
-  val comparativeLevel : int
-  val bitwiseLevel : int
-  val getParenthLevel : Cil.exp -> int
-  class type cilPrinter =
-    object
-      method dBlock : Pervasives.out_channel -> int -> Cil.block -> unit
-      method dGlobal : Pervasives.out_channel -> Cil.global -> unit
-      method dInit : Pervasives.out_channel -> int -> Cil.init -> unit
-      method dStmt : Pervasives.out_channel -> int -> Cil.stmt -> unit
-      method pAttr : Cil.attribute -> Pretty.doc * bool
-      method pAttrParam : unit -> Cil.attrparam -> Pretty.doc
-      method pAttrs : unit -> Cil.attributes -> Pretty.doc
-      method pBlock : unit -> Cil.block -> Pretty.doc
-      method pExp : unit -> Cil.exp -> Pretty.doc
-      method pFieldDecl : unit -> Cil.fieldinfo -> Pretty.doc
-      method pGlobal : unit -> Cil.global -> Pretty.doc
-      method pInit : unit -> Cil.init -> Pretty.doc
-      method pInstr : unit -> Cil.instr -> Pretty.doc
-      method pLabel : unit -> Cil.label -> Pretty.doc
-      method pLineDirective : ?forcefile:bool -> Cil.location -> Pretty.doc
-      method pLval : unit -> Cil.lval -> Pretty.doc
-      method pOffset : Pretty.doc -> Cil.offset -> Pretty.doc
-      method pStmt : unit -> Cil.stmt -> Pretty.doc
-      method pStmtKind : Cil.stmt -> unit -> Cil.stmtkind -> Pretty.doc
-      method pType : Pretty.doc option -> unit -> Cil.typ -> Pretty.doc
-      method pVDecl : unit -> Cil.varinfo -> Pretty.doc
-      method pVar : Cil.varinfo -> Pretty.doc
-    end
-  class defaultCilPrinterClass : cilPrinter
-  val defaultCilPrinter : Cil.cilPrinter
-  class plainCilPrinterClass : cilPrinter
-  val plainCilPrinter : Cil.cilPrinter
-  val printerForMaincil : Cil.cilPrinter Pervasives.ref
-  val printType : Cil.cilPrinter -> unit -> Cil.typ -> Pretty.doc
-  val printExp : Cil.cilPrinter -> unit -> Cil.exp -> Pretty.doc
-  val printLval : Cil.cilPrinter -> unit -> Cil.lval -> Pretty.doc
-  val printGlobal : Cil.cilPrinter -> unit -> Cil.global -> Pretty.doc
-  val printAttr : Cil.cilPrinter -> unit -> Cil.attribute -> Pretty.doc
-  val printAttrs : Cil.cilPrinter -> unit -> Cil.attributes -> Pretty.doc
-  val printInstr : Cil.cilPrinter -> unit -> Cil.instr -> Pretty.doc
-  val printStmt : Cil.cilPrinter -> unit -> Cil.stmt -> Pretty.doc
-  val printBlock : Cil.cilPrinter -> unit -> Cil.block -> Pretty.doc
-  val dumpStmt :
-    Cil.cilPrinter -> Pervasives.out_channel -> int -> Cil.stmt -> unit
-  val dumpBlock :
-    Cil.cilPrinter -> Pervasives.out_channel -> int -> Cil.block -> unit
-  val printInit : Cil.cilPrinter -> unit -> Cil.init -> Pretty.doc
-  val dumpInit :
-    Cil.cilPrinter -> Pervasives.out_channel -> int -> Cil.init -> unit
-  val d_type : unit -> Cil.typ -> Pretty.doc
-  val d_exp : unit -> Cil.exp -> Pretty.doc
-  val d_lval : unit -> Cil.lval -> Pretty.doc
-  val d_offset : Pretty.doc -> unit -> Cil.offset -> Pretty.doc
-  val d_init : unit -> Cil.init -> Pretty.doc
-  val d_binop : unit -> Cil.binop -> Pretty.doc
-  val d_unop : unit -> Cil.unop -> Pretty.doc
-  val d_attr : unit -> Cil.attribute -> Pretty.doc
-  val d_attrparam : unit -> Cil.attrparam -> Pretty.doc
-  val d_attrlist : unit -> Cil.attributes -> Pretty.doc
-  val d_instr : unit -> Cil.instr -> Pretty.doc
-  val d_label : unit -> Cil.label -> Pretty.doc
-  val d_stmt : unit -> Cil.stmt -> Pretty.doc
-  val d_block : unit -> Cil.block -> Pretty.doc
-  val d_global : unit -> Cil.global -> Pretty.doc
-  val dn_exp : unit -> Cil.exp -> Pretty.doc
-  val dn_lval : unit -> Cil.lval -> Pretty.doc
-  val dn_init : unit -> Cil.init -> Pretty.doc
-  val dn_type : unit -> Cil.typ -> Pretty.doc
-  val dn_global : unit -> Cil.global -> Pretty.doc
-  val dn_attrlist : unit -> Cil.attributes -> Pretty.doc
-  val dn_attr : unit -> Cil.attribute -> Pretty.doc
-  val dn_attrparam : unit -> Cil.attrparam -> Pretty.doc
-  val dn_stmt : unit -> Cil.stmt -> Pretty.doc
-  val dn_instr : unit -> Cil.instr -> Pretty.doc
-  val d_shortglobal : unit -> Cil.global -> Pretty.doc
-  val dumpGlobal :
-    Cil.cilPrinter -> Pervasives.out_channel -> Cil.global -> unit
-  val dumpFile :
-    Cil.cilPrinter -> Pervasives.out_channel -> string -> Cil.file -> unit
-  val bug : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val unimp : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val error : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val errorLoc :
-    Cil.location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val warn : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val warnOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val warnContext : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val warnContextOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val warnLoc :
-    Cil.location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val d_plainexp : unit -> Cil.exp -> Pretty.doc
-  val d_plaininit : unit -> Cil.init -> Pretty.doc
-  val d_plainlval : unit -> Cil.lval -> Pretty.doc
-  val d_plaintype : unit -> Cil.typ -> Pretty.doc
-  val uniqueVarNames : Cil.file -> unit
-  val peepHole2 :
-    (Cil.instr * Cil.instr -> Cil.instr list option) -> Cil.stmt list -> unit
-  val peepHole1 :
-    (Cil.instr -> Cil.instr list option) -> Cil.stmt list -> unit
-  exception SizeOfError of string * Cil.typ
-  val bitsSizeOf : Cil.typ -> int
-  val sizeOf : Cil.typ -> Cil.exp
-  val alignOf_int : Cil.typ -> int
-  val bitsOffset : Cil.typ -> Cil.offset -> int * int
-  val char_is_unsigned : bool Pervasives.ref
-  val little_endian : bool Pervasives.ref
-  val underscore_name : bool Pervasives.ref
-  val locUnknown : Cil.location
-  val get_instrLoc : Cil.instr -> Cil.location
-  val get_globalLoc : Cil.global -> Cil.location
-  val get_stmtLoc : Cil.stmtkind -> Cil.location
-  val dExp : Pretty.doc -> Cil.exp
-  val dInstr : Pretty.doc -> Cil.location -> Cil.instr
-  val dGlobal : Pretty.doc -> Cil.location -> Cil.global
-  val mapNoCopy : ('a -> 'a) -> 'a list -> 'a list
-  val mapNoCopyList : ('a -> 'a list) -> 'a list -> 'a list
-  val startsWith : string -> string -> bool
-  type formatArg =
-      Fe of Cil.exp
-    | Feo of Cil.exp option
-    | Fu of Cil.unop
-    | Fb of Cil.binop
-    | Fk of Cil.ikind
-    | FE of Cil.exp list
-    | Ff of (string * Cil.typ * Cil.attributes)
-    | FF of (string * Cil.typ * Cil.attributes) list
-    | Fva of bool
-    | Fv of Cil.varinfo
-    | Fl of Cil.lval
-    | Flo of Cil.lval option
-    | Fo of Cil.offset
-    | Fc of Cil.compinfo
-    | Fi of Cil.instr
-    | FI of Cil.instr list
-    | Ft of Cil.typ
-    | Fd of int
-    | Fg of string
-    | Fs of Cil.stmt
-    | FS of Cil.stmt list
-    | FA of Cil.attributes
-    | Fp of Cil.attrparam
-    | FP of Cil.attrparam list
-    | FX of string
-  val d_formatarg : unit -> Cil.formatArg -> Pretty.doc
-  val lowerConstants : bool Pervasives.ref
-end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.nopCilVisitor.html b/cil/doc/api/type_Cil.nopCilVisitor.html deleted file mode 100644 index 0ac6c96..0000000 --- a/cil/doc/api/type_Cil.nopCilVisitor.html +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.nopCilVisitor - - -Cil.cilVisitor \ No newline at end of file diff --git a/cil/doc/api/type_Cil.plainCilPrinterClass.html b/cil/doc/api/type_Cil.plainCilPrinterClass.html deleted file mode 100644 index ecd6317..0000000 --- a/cil/doc/api/type_Cil.plainCilPrinterClass.html +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cil.plainCilPrinterClass - - -Cil.cilPrinter \ No newline at end of file diff --git a/cil/doc/api/type_Cillower.html b/cil/doc/api/type_Cillower.html deleted file mode 100644 index a8924ed..0000000 --- a/cil/doc/api/type_Cillower.html +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Cillower - - -sig val lowerEnumVisitor : Cil.cilVisitor end \ No newline at end of file diff --git a/cil/doc/api/type_Clist.html b/cil/doc/api/type_Clist.html deleted file mode 100644 index c7dbd02..0000000 --- a/cil/doc/api/type_Clist.html +++ /dev/null @@ -1,44 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Clist - - -sig
-  type 'a clist =
-      CList of 'a list
-    | CConsL of 'a * 'a Clist.clist
-    | CConsR of 'a Clist.clist * 'a
-    | CSeq of 'a Clist.clist * 'a Clist.clist
-  val toList : 'a Clist.clist -> 'a list
-  val fromList : 'a list -> 'a Clist.clist
-  val single : 'a -> 'a Clist.clist
-  val empty : 'a Clist.clist
-  val append : 'a Clist.clist -> 'a Clist.clist -> 'a Clist.clist
-  val checkBeforeAppend : 'a Clist.clist -> 'a Clist.clist -> bool
-  val length : 'a Clist.clist -> int
-  val map : ('a -> 'b) -> 'a Clist.clist -> 'b Clist.clist
-  val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b Clist.clist -> 'a
-  val iter : ('a -> unit) -> 'a Clist.clist -> unit
-  val rev : ('a -> 'a) -> 'a Clist.clist -> 'a Clist.clist
-  val docCList :
-    Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a Clist.clist -> Pretty.doc
-end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.BackwardsDataFlow.html b/cil/doc/api/type_Dataflow.BackwardsDataFlow.html deleted file mode 100644 index 78ffeba..0000000 --- a/cil/doc/api/type_Dataflow.BackwardsDataFlow.html +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.BackwardsDataFlow - - -functor (T : BackwardsTransfer) ->
-  sig val compute : Cil.stmt list -> unit end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.BackwardsTransfer.html b/cil/doc/api/type_Dataflow.BackwardsTransfer.html deleted file mode 100644 index 763df74..0000000 --- a/cil/doc/api/type_Dataflow.BackwardsTransfer.html +++ /dev/null @@ -1,44 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.BackwardsTransfer - - -sig
-  val name : string
-  val debug : bool Pervasives.ref
-  type t
-  val pretty : unit -> Dataflow.BackwardsTransfer.t -> Pretty.doc
-  val stmtStartData : Dataflow.BackwardsTransfer.t Inthash.t
-  val combineStmtStartData :
-    Cil.stmt ->
-    old:Dataflow.BackwardsTransfer.t ->
-    Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t option
-  val combineSuccessors :
-    Dataflow.BackwardsTransfer.t ->
-    Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t
-  val doStmt : Cil.stmt -> Dataflow.BackwardsTransfer.t Dataflow.action
-  val doInstr :
-    Cil.instr ->
-    Dataflow.BackwardsTransfer.t ->
-    Dataflow.BackwardsTransfer.t Dataflow.action
-  val filterStmt : Cil.stmt -> Cil.stmt -> bool
-end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.ForwardsDataFlow.html b/cil/doc/api/type_Dataflow.ForwardsDataFlow.html deleted file mode 100644 index a042cfc..0000000 --- a/cil/doc/api/type_Dataflow.ForwardsDataFlow.html +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.ForwardsDataFlow - - -functor (T : ForwardsTransfer) -> sig val compute : Cil.stmt list -> unit end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.ForwardsTransfer.html b/cil/doc/api/type_Dataflow.ForwardsTransfer.html deleted file mode 100644 index 1e4d48b..0000000 --- a/cil/doc/api/type_Dataflow.ForwardsTransfer.html +++ /dev/null @@ -1,51 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow.ForwardsTransfer - - -sig
-  val name : string
-  val debug : bool Pervasives.ref
-  type t
-  val copy : Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
-  val stmtStartData : Dataflow.ForwardsTransfer.t Inthash.t
-  val pretty : unit -> Dataflow.ForwardsTransfer.t -> Pretty.doc
-  val computeFirstPredecessor :
-    Cil.stmt -> Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
-  val combinePredecessors :
-    Cil.stmt ->
-    old:Dataflow.ForwardsTransfer.t ->
-    Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t option
-  val doInstr :
-    Cil.instr ->
-    Dataflow.ForwardsTransfer.t ->
-    Dataflow.ForwardsTransfer.t Dataflow.action
-  val doStmt :
-    Cil.stmt ->
-    Dataflow.ForwardsTransfer.t ->
-    Dataflow.ForwardsTransfer.t Dataflow.stmtaction
-  val doGuard :
-    Cil.exp ->
-    Dataflow.ForwardsTransfer.t ->
-    Dataflow.ForwardsTransfer.t Dataflow.guardaction
-  val filterStmt : Cil.stmt -> bool
-end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.html b/cil/doc/api/type_Dataflow.html deleted file mode 100644 index fa03476..0000000 --- a/cil/doc/api/type_Dataflow.html +++ /dev/null @@ -1,85 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dataflow - - -sig
-  type 'a action = Default | Done of 'a | Post of ('a -> 'a)
-  type 'a stmtaction = SDefault | SDone | SUse of 'a
-  type 'a guardaction = GDefault | GUse of 'a | GUnreachable
-  module type ForwardsTransfer =
-    sig
-      val name : string
-      val debug : bool Pervasives.ref
-      type t
-      val copy : Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
-      val stmtStartData : Dataflow.ForwardsTransfer.t Inthash.t
-      val pretty : unit -> Dataflow.ForwardsTransfer.t -> Pretty.doc
-      val computeFirstPredecessor :
-        Cil.stmt ->
-        Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
-      val combinePredecessors :
-        Cil.stmt ->
-        old:Dataflow.ForwardsTransfer.t ->
-        Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t option
-      val doInstr :
-        Cil.instr ->
-        Dataflow.ForwardsTransfer.t ->
-        Dataflow.ForwardsTransfer.t Dataflow.action
-      val doStmt :
-        Cil.stmt ->
-        Dataflow.ForwardsTransfer.t ->
-        Dataflow.ForwardsTransfer.t Dataflow.stmtaction
-      val doGuard :
-        Cil.exp ->
-        Dataflow.ForwardsTransfer.t ->
-        Dataflow.ForwardsTransfer.t Dataflow.guardaction
-      val filterStmt : Cil.stmt -> bool
-    end
-  module ForwardsDataFlow :
-    functor (T : ForwardsTransfer) ->
-      sig val compute : Cil.stmt list -> unit end
-  module type BackwardsTransfer =
-    sig
-      val name : string
-      val debug : bool Pervasives.ref
-      type t
-      val pretty : unit -> Dataflow.BackwardsTransfer.t -> Pretty.doc
-      val stmtStartData : Dataflow.BackwardsTransfer.t Inthash.t
-      val combineStmtStartData :
-        Cil.stmt ->
-        old:Dataflow.BackwardsTransfer.t ->
-        Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t option
-      val combineSuccessors :
-        Dataflow.BackwardsTransfer.t ->
-        Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t
-      val doStmt : Cil.stmt -> Dataflow.BackwardsTransfer.t Dataflow.action
-      val doInstr :
-        Cil.instr ->
-        Dataflow.BackwardsTransfer.t ->
-        Dataflow.BackwardsTransfer.t Dataflow.action
-      val filterStmt : Cil.stmt -> Cil.stmt -> bool
-    end
-  module BackwardsDataFlow :
-    functor (T : BackwardsTransfer) ->
-      sig val compute : Cil.stmt list -> unit end
-end \ No newline at end of file diff --git a/cil/doc/api/type_Dominators.html b/cil/doc/api/type_Dominators.html deleted file mode 100644 index a9fef53..0000000 --- a/cil/doc/api/type_Dominators.html +++ /dev/null @@ -1,32 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Dominators - - -sig
-  val computeIDom : Cil.fundec -> Cil.stmt option Inthash.t
-  val getIdom : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option
-  val dominates : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool
-  val findNaturalLoops :
-    Cil.fundec ->
-    Cil.stmt option Inthash.t -> (Cil.stmt * Cil.stmt list) list
-end \ No newline at end of file diff --git a/cil/doc/api/type_Errormsg.html b/cil/doc/api/type_Errormsg.html deleted file mode 100644 index 3ad0a86..0000000 --- a/cil/doc/api/type_Errormsg.html +++ /dev/null @@ -1,64 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Errormsg - - -sig
-  val logChannel : Pervasives.out_channel Pervasives.ref
-  val debugFlag : bool Pervasives.ref
-  val verboseFlag : bool Pervasives.ref
-  val warnFlag : bool Pervasives.ref
-  exception Error
-  val error : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val bug : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val unimp : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val s : 'a -> 'b
-  val hadErrors : bool Pervasives.ref
-  val warn : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val warnOpt : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val log : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val logg : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val null : ('a, unit, Pretty.doc, unit) format4 -> 'a
-  val pushContext : (unit -> Pretty.doc) -> unit
-  val popContext : unit -> unit
-  val showContext : unit -> unit
-  val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b
-  val newline : unit -> unit
-  val newHline : unit -> unit
-  val getPosition : unit -> int * string * int
-  val getHPosition : unit -> int * string
-  val setHLine : int -> unit
-  val setHFile : string -> unit
-  val setCurrentLine : int -> unit
-  val setCurrentFile : string -> unit
-  type location = { file : string; line : int; hfile : string; hline : int; }
-  val d_loc : unit -> Errormsg.location -> Pretty.doc
-  val d_hloc : unit -> Errormsg.location -> Pretty.doc
-  val getLocation : unit -> Errormsg.location
-  val parse_error : string -> 'a
-  val locUnknown : Errormsg.location
-  val readingFromStdin : bool Pervasives.ref
-  val startParsing : ?useBasename:bool -> string -> Lexing.lexbuf
-  val startParsingFromString :
-    ?file:string -> ?line:int -> string -> Lexing.lexbuf
-  val finishParsing : unit -> unit
-end \ No newline at end of file diff --git a/cil/doc/api/type_Formatcil.html b/cil/doc/api/type_Formatcil.html deleted file mode 100644 index 7c5139b..0000000 --- a/cil/doc/api/type_Formatcil.html +++ /dev/null @@ -1,45 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Formatcil - - -sig
-  val cExp : string -> (string * Cil.formatArg) list -> Cil.exp
-  val cLval : string -> (string * Cil.formatArg) list -> Cil.lval
-  val cType : string -> (string * Cil.formatArg) list -> Cil.typ
-  val cInstr :
-    string -> Cil.location -> (string * Cil.formatArg) list -> Cil.instr
-  val cStmt :
-    string ->
-    (string -> Cil.typ -> Cil.varinfo) ->
-    Cil.location -> (string * Cil.formatArg) list -> Cil.stmt
-  val cStmts :
-    string ->
-    (string -> Cil.typ -> Cil.varinfo) ->
-    Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list
-  val dExp : string -> Cil.exp -> Cil.formatArg list option
-  val dLval : string -> Cil.lval -> Cil.formatArg list option
-  val dType : string -> Cil.typ -> Cil.formatArg list option
-  val dInstr : string -> Cil.instr -> Cil.formatArg list option
-  val noMemoize : bool Pervasives.ref
-  val test : unit -> unit
-end \ No newline at end of file diff --git a/cil/doc/api/type_Pretty.MakeMapPrinter.html b/cil/doc/api/type_Pretty.MakeMapPrinter.html deleted file mode 100644 index 0b9d35e..0000000 --- a/cil/doc/api/type_Pretty.MakeMapPrinter.html +++ /dev/null @@ -1,42 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Pretty.MakeMapPrinter - - -functor
-  (Map : sig
-           type key
-           type 'a t
-           val fold :
-             (Pretty.MakeMapPrinter.key -> 'a -> 'b -> 'b) ->
-             'a Pretty.MakeMapPrinter.t -> 'b -> 'b
-         end) ->
-  sig
-    val docMap :
-      ?sep:Pretty.doc ->
-      (Map.key -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
-    val d_map :
-      ?dmaplet:(Pretty.doc -> Pretty.doc -> Pretty.doc) ->
-      string ->
-      (unit -> Map.key -> Pretty.doc) ->
-      (unit -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
-  end \ No newline at end of file diff --git a/cil/doc/api/type_Pretty.MakeSetPrinter.html b/cil/doc/api/type_Pretty.MakeSetPrinter.html deleted file mode 100644 index c5e0466..0000000 --- a/cil/doc/api/type_Pretty.MakeSetPrinter.html +++ /dev/null @@ -1,40 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Pretty.MakeSetPrinter - - -functor
-  (Set : sig
-           type elt
-           type t
-           val fold :
-             (Pretty.MakeSetPrinter.elt -> 'a -> 'a) ->
-             Pretty.MakeSetPrinter.t -> 'a -> 'a
-         end) ->
-  sig
-    val docSet :
-      ?sep:Pretty.doc ->
-      (Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
-    val d_set :
-      string ->
-      (unit -> Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
-  end \ No newline at end of file diff --git a/cil/doc/api/type_Pretty.html b/cil/doc/api/type_Pretty.html deleted file mode 100644 index fc70f65..0000000 --- a/cil/doc/api/type_Pretty.html +++ /dev/null @@ -1,111 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Pretty - - -sig
-  type doc
-  val nil : Pretty.doc
-  val ( ++ ) : Pretty.doc -> Pretty.doc -> Pretty.doc
-  val concat : Pretty.doc -> Pretty.doc -> Pretty.doc
-  val text : string -> Pretty.doc
-  val num : int -> Pretty.doc
-  val real : float -> Pretty.doc
-  val chr : char -> Pretty.doc
-  val line : Pretty.doc
-  val leftflush : Pretty.doc
-  val break : Pretty.doc
-  val align : Pretty.doc
-  val unalign : Pretty.doc
-  val mark : Pretty.doc
-  val unmark : Pretty.doc
-  val indent : int -> Pretty.doc -> Pretty.doc
-  val markup : Pretty.doc -> Pretty.doc
-  val seq :
-    sep:Pretty.doc ->
-    doit:('a -> Pretty.doc) -> elements:'a list -> Pretty.doc
-  val docList :
-    ?sep:Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a list -> Pretty.doc
-  val d_list :
-    string -> (unit -> 'a -> Pretty.doc) -> unit -> 'a list -> Pretty.doc
-  val docArray :
-    ?sep:Pretty.doc ->
-    (int -> 'a -> Pretty.doc) -> unit -> 'a array -> Pretty.doc
-  val docOpt : ('a -> Pretty.doc) -> unit -> 'a option -> Pretty.doc
-  val d_int32 : int32 -> Pretty.doc
-  val f_int32 : unit -> int32 -> Pretty.doc
-  val d_int64 : int64 -> Pretty.doc
-  val f_int64 : unit -> int64 -> Pretty.doc
-  module MakeMapPrinter :
-    functor
-      (Map : sig
-               type key
-               type 'a t
-               val fold :
-                 (Pretty.MakeMapPrinter.key -> 'a -> 'b -> 'b) ->
-                 'a Pretty.MakeMapPrinter.t -> 'b -> 'b
-             end) ->
-      sig
-        val docMap :
-          ?sep:Pretty.doc ->
-          (Map.key -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
-        val d_map :
-          ?dmaplet:(Pretty.doc -> Pretty.doc -> Pretty.doc) ->
-          string ->
-          (unit -> Map.key -> Pretty.doc) ->
-          (unit -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
-      end
-  module MakeSetPrinter :
-    functor
-      (Set : sig
-               type elt
-               type t
-               val fold :
-                 (Pretty.MakeSetPrinter.elt -> 'a -> 'a) ->
-                 Pretty.MakeSetPrinter.t -> 'a -> 'a
-             end) ->
-      sig
-        val docSet :
-          ?sep:Pretty.doc ->
-          (Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
-        val d_set :
-          string ->
-          (unit -> Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
-      end
-  val insert : unit -> Pretty.doc -> Pretty.doc
-  val dprintf : ('a, unit, Pretty.doc, Pretty.doc) format4 -> 'a
-  val gprintf :
-    (Pretty.doc -> 'a) -> ('b, unit, Pretty.doc, 'a) format4 -> 'b
-  val fprint : Pervasives.out_channel -> width:int -> Pretty.doc -> unit
-  val sprint : width:int -> Pretty.doc -> string
-  val fprintf :
-    Pervasives.out_channel -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val printf : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val eprintf : ('a, unit, Pretty.doc) Pervasives.format -> 'a
-  val withPrintDepth : int -> (unit -> unit) -> unit
-  val printDepth : int Pervasives.ref
-  val printIndent : bool Pervasives.ref
-  val fastMode : bool Pervasives.ref
-  val flushOften : bool Pervasives.ref
-  val countNewLines : int Pervasives.ref
-  val auto_printer : string -> 'a
-end \ No newline at end of file diff --git a/cil/doc/api/type_Stats.html b/cil/doc/api/type_Stats.html deleted file mode 100644 index 77cd218..0000000 --- a/cil/doc/api/type_Stats.html +++ /dev/null @@ -1,36 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - -CIL API Documentation (version 1.3.5) : Stats - - -sig
-  val reset : bool -> unit
-  exception NoPerfCount
-  val has_performance_counters : unit -> bool
-  val sample_pentium_perfcount_20 : unit -> int
-  val sample_pentium_perfcount_10 : unit -> int
-  val time : string -> ('a -> 'b) -> 'a -> 'b
-  val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
-  val print : Pervasives.out_channel -> string -> unit
-  val lastTime : float Pervasives.ref
-  val timethis : ('a -> 'b) -> 'a -> 'b
-end \ No newline at end of file diff --git a/cil/doc/changes.html b/cil/doc/changes.html deleted file mode 100644 index 17ffdf7..0000000 --- a/cil/doc/changes.html +++ /dev/null @@ -1,486 +0,0 @@ - - - - - - - - - - - - - -Changes - - - -Previous -Up -
- -

20  Changes

-
  • -May 20, 2006: Released version 1.3.5 -
  • May 19, 2006: Makefile.cil.in/Makefile.cil have - been renamed Makefile.in/Makefile. And maincil.ml has - been renamed main.ml. -
  • May 18, 2006: Added a new module Cfg to compute the - control-flow graph. Unlike the older Cil.computeCFGInfo, - the new version does not modify the code. -
  • May 18, 2006: Added several new analyses: reaching - definitions, available expressions, liveness analysis, and dead code - elimination. See Section 8. -
  • May 2, 2006: Added a flag --noInsertImplicitCasts. - When this flag is used, CIL code will only include casts inserted by - the programmer. Implicit coercions are not changed to explicit casts. -
  • April 16, 2006: Minor improvements to the --stats - flag (Section 7.2). We now use Pentium performance - counters by default, if your processor supports them. -
  • April 10, 2006: Extended machdep.c to support - microcontroller compilers where the struct alignment of integer - types does not match the size of the type. Thanks to Nathan - Cooprider for the patch. -
  • April 6, 2006: Fix for global initializers of unions when - the union field being initialized is not the first one, and for - missing initializers of unions when the first field is not the - largest field. -
  • April 6, 2006: Fix for bitfields in the SFI module. -
  • April 6, 2006: Various fixes for gcc attributes. - packed, section, and always_inline attributes are now - parsed correctly. Also fixed printing of attributes on enum types. -
  • March 30, 2006: Fix for rmtemps.ml, which deletes - unused inline functions. When in gcc mode CIL now leaves all - inline functions in place, since gcc treats these as externally - visible. -
  • March 15, 2006: Fix for typeof(e) when e has type - void. -
  • March 3, 2006: Assume inline assembly instructions can - fall through for the purposes of adding return statements. Thanks to - Nathan Cooprider for the patch. -
  • February 27, 2006: Fix for extern inline functions when - the output of CIL is fed back into CIL. -
  • January 30, 2006: Fix parsing of switch without braces. -
  • January 30, 2006: Allow `$' to appear in identifiers. -
  • January 13, 2006: Added support for gcc's alias attribute - on functions. See Section 16.2, item 8. -
  • December 9, 2005: Christoph Spiel fixed the Golf and - Olf modules so that Golf can be used with the points-to analysis. - He also added performance fixes and cleaned up the documentation. -
  • December 1, 2005: Major rewrite of the ext/callgraph module. -
  • December 1, 2005: Preserve enumeration constants in CIL. Default -is the old behavior to replace them with integers. -
  • November 30, 2005: Added support for many GCC __builtin - functions. -
  • November 30, 2005: Added the EXTRAFEATURES configure - option, making it easier to add Features to the build process. -
  • November 23, 2005: In MSVC mode do not remove any locals whose name - appears as a substring in an inline assembly. -
  • November 23, 2005: Do not add a return to functions that have the - noreturn attribute. -
  • November 22, 2005: Released version 1.3.4 -
  • November 21, 2005: Performance and correctness fixes for - the Points-to Analysis module. Thanks to Christoph Spiel for the - patches. -
  • October 5, 2005: CIL now builds on SPARC/Solaris. Thanks - to Nick Petroni and Remco van Engelen for the patches. -
  • September 26, 2005: CIL no longer uses the `-I-' flag - by default when preprocessing with gcc. -
  • August 24, 2005: Added a command-line option - “--forceRLArgEval” that forces function arguments to be evaluated - right-to-left. This is the default behavior in unoptimized gcc and - MSVC, but the order of evaluation is undefined when using - optimizations, unless you apply this CIL transformation. This flag - does not affect the order of evaluation of e.g. binary operators, - which remains undefined. Thanks to Nathan Cooprider for the patch. -
  • August 9, 2005: Fixed merging when there are more than 20 - input files. -
  • August 3, 2005: When merging, it is now an error to - declare the same global variable twice with different initializers. -
  • July 27, 2005: Fixed bug in transparent unions. -
  • July 27, 2005: Fixed bug in collectInitializer. Thanks to - Benjamin Monate for the patch. -
  • July 26, 2005: Better support for extended inline assembly - in gcc. -
  • July 26, 2005: Added many more gcc __builtin* functions - to CIL. Most are treated as Call instructions, but a few are - translated into expressions so that they can be used in global - initializers. For example, “__builtin_offsetof(t, field)” is - rewritten as “&((t*)0)->field”, the traditional way of calculating - an offset. -
  • July 18, 2005: Fixed bug in the constant folding of shifts - when the second argument was negative or too large. -
  • July 18, 2005: Fixed bug where casts were not always - inserted in function calls. -
  • June 10, 2005: Fixed bug in the code that makes implicit - returns explicit. We weren't handling switch blocks correctly. -
  • June 1, 2005: Released version 1.3.3 -
  • May 31, 2005: Fixed handling of noreturn attribute for function - pointers. -
  • May 30, 2005: Fixed bugs in the handling of constructors in gcc. -
  • May 30, 2005: Fixed bugs in the generation of global variable IDs. -
  • May 27, 2005: Reimplemented the translation of function calls so - that we can intercept some builtins. This is important for the uses of - __builtin_constant_p in constants. -
  • May 27, 2005: Export the plainCilPrinter, for debugging. -
  • May 27, 2005: Fixed bug with printing of const attribute for - arrays. -
  • May 27, 2005: Fixed bug in generation of type signatures. Now they - should not contain expressions anymore, so you can use structural equality. - This used to lead to Out_of_Memory exceptions. -
  • May 27, 2005: Fixed bug in type comparisons using - TBuiltin_va_list. -
  • May 27, 2005: Improved the constant folding in array lengths and - case expressions. -
  • May 27, 2005: Added the __builtin_frame_address to the set - of gcc builtins. -
  • May 27, 2005: Added the CIL project to SourceForge. -
  • April 23, 2005: The cattr field was not visited. -
  • March 6, 2005: Debian packaging support -
  • February 16, 2005: Merger fixes. -
  • February 11, 2005: Fixed a bug in --dopartial. Thanks to -Nathan Cooprider for this fix. -
  • January 31, 2005: Make sure the input file is closed even if a - parsing error is encountered. -
  • January 11, 2005: Released version 1.3.2 -
  • January 11, 2005: Fixed printing of integer constants whose - integer kind is shorter than an int. -
  • January 11, 2005: Added checks for negative size arrays and arrays - too big. -
  • January 10, 2005: Added support for GCC attribute “volatile” for - tunctions (as a synonim for noreturn). -
  • January 10, 2005: Improved the comparison of array sizes when - comparing array types. -
  • January 10, 2005: Fixed handling of shell metacharacters in the - cilly command lione. -
  • January 10, 2005: Fixed dropping of cast in initialization of - local variable with the result of a function call. -
  • January 10, 2005: Fixed some structural comparisons that were - broken in the Ocaml 3.08. -
  • January 10, 2005: Fixed the unrollType function to not forget - attributes. -
  • January 10, 2005: Better keeping track of locations of function - prototypes and definitions. -
  • January 10, 2005: Fixed bug with the expansion of enumeration - constants in attributes. -
  • October 18, 2004: Fixed a bug in cabsvisit.ml. CIl would wrap a - BLOCK around a single atom unnecessarily. -
  • August 7, 2004: Released version 1.3.1 -
  • August 4, 2004: Fixed a bug in splitting of structs using - --dosimplify -
  • July 29, 2004: Minor changes to the type typeSig (type signatures) - to ensure that they do not contain types, so that you can do structural - comparison without danger of nontermination. -
  • July 28, 2004: Ocaml version 3.08 is required. Numerous small - changes while porting to Ocaml 3.08. -
  • July 7, 2004: Released version 1.2.6 -
  • July 2, 2004: Character constants such as 'c' should - have type int, not char. Added a utility function - Cil.charConstToInt that sign-extends chars greater than 128, if needed. -
  • July 2, 2004: Fixed a bug that was casting values to int - before applying the logical negation operator !. This caused - problems for floats, and for integer types bigger than int. -
  • June 13, 2004: Added the field sallstmts to a function - description, to hold all statements in the function. -
  • June 13, 2004: Added new extensions for data flow analyses, and - for computing dominators. -
  • June 10, 2004: Force initialization of CIL at the start of -Cabs2cil. -
  • June 9, 2004: Added support for GCC __attribute_used__ -
  • April 7, 2004: Released version 1.2.5 -
  • April 7, 2004: Allow now to run ./configure CC=cl and set the MSVC -compiler to be the default. The MSVC driver will now select the default name -of the .exe file like the CL compiler. -
  • April 7, 2004: Fixed a bug in the driver. The temporary files are -deleted by the Perl script before the CL compiler gets to them? -
  • April 7, 2004: Added the - form of arguments to the MSVC driver. -
  • April 7, 2004: Added a few more GCC-specific string escapes, (, [, -{, %, E. -
  • April 7, 2004: Fixed bug with continuation lines in MSVC. -
  • April 6, 2004: Fixed embarassing bug in the parser: the precedence - of casts and unary operators was switched. -
  • April 5, 2004: Fixed a bug involving statements mixed between -declarations containing initializers. Now we make sure that the initializers -are run in the proper order with respect to the statements. -
  • April 5, 2004: Fixed a bug in the merger. The merger was keeping -separate alpha renaming talbes (namespaces) for variables and types. This -means that it might end up with a type and a variable named the same way, if -they come from different files, which breaks an important CIL invariant. -
  • March 11, 2004 : Fixed a bug in the Cil.copyFunction function. The -new local variables were not getting fresh IDs. -
  • March 5, 2004: Fixed a bug in the handling of static function - prototypes in a block scope. They used to be renamed. Now we just consider - them global. -
  • February 20, 2004: Released version 1.2.4 -
  • February 15, 2004: Changed the parser to allow extra semicolons - after field declarations. -
  • February 14, 2004: Changed the Errormsg functions: error, unimp, -bug to not raise an exception. Instead they just set Errormsg.hadErrors. -
  • February 13, 2004: Change the parsing of attributes to recognize - enumeration constants. -
  • February 10, 2004: In some versions of gcc the identifier - _{thread is an identifier and in others it is a keyword. Added code - during configuration to detect which is the case. -
  • January 7, 2004: Released version 1.2.3 -
  • January 7, 2004: Changed the alpha renamer to be less -conservative. It will remember all versions of a name that were seen and will -only create a new name if we have not seen one. -
  • December 30, 2003 : Extended the cilly command to understand - better linker command options -lfoo. -
  • December 5, 2003: Added markup commands to the pretty-printer -module. Also, changed the “@<” left-flush command into “@''. -
  • December 4, 2003: Wide string literals are now handled -directly by Cil (rather than being exploded into arrays). This is -apparently handy for Microsoft Device Driver APIs that use intrinsic -functions that require literal constant wide-string arguments. -
  • December 3, 2003: Added support for structured exception handling - extensions for the Microsoft compilers. -
  • December 1, 2003: Fixed a Makefile bug in the generation of the -Cil library (e.g., cil.cma) that was causing it to be unusable. Thanks -to KEvin Millikin for pointing out this bug. -
  • November 26, 2003: Added support for linkage specifications - (extern “C”). -
  • November 26, 2003: Added the ocamlutil directory to contain some -utilities shared with other projects. -
  • November 25, 2003: Released version 1.2.2 -
  • November 24, 2003: Fixed a bug that allowed a static local to - conflict with a global with the same name that is declared later in the - file. -
  • November 24, 2003: Removed the --keep option of the cilly - driver and replaced it with --save-temps. -
  • November 24, 2003: Added printing of what CIL features are being - run. -
  • November 24, 2003: Fixed a bug that resulted in attributes being - dropped for integer types. -
  • November 11, 2003: Fixed a bug in the visitor for enumeration - definitions. -
  • October 24, 2003: Fixed a problem in the configuration script. It - was not recognizing the Ocaml version number for beta versions. -
  • October 15, 2003: Fixed a problem in version 1.2.1 that was - preventing compilation on OCaml 3.04. -
  • September 17, 2003: Released version 1.2.1. -
  • September 7, 2003: Redesigned the interface for choosing - #line directive printing styles. Cil.printLn and - Cil.printLnComment have been merged into Cil.lineDirectiveStyle. -
  • August 8, 2003: Do not silently pad out functions calls with -arguments to match the prototype. -
  • August 1, 2003: A variety of fixes suggested by Steve Chamberlain: -initializers for externs, prohibit float literals in enum, initializers for -unsized arrays were not working always, an overflow problem in Ocaml, changed -the processing of attributes before struct specifiers
    -
    -
  • July 14, 2003: Add basic support for GCC's "__thread" storage -qualifier. If given, it will appear as a "thread" attribute at the top of the -type of the declared object. Treatment is very similar to "__declspec(...)" -in MSVC
    -
    -
  • July 8, 2003: Fixed some of the __alignof computations. Fixed - bug in the designated initializers for arrays (Array.get error). -
  • July 8, 2003: Fixed infinite loop bug (Stack Overflow) in the - visitor for __alignof. -
  • July 8, 2003: Fixed bug in the conversion to CIL. A function or - array argument of - the GCC __typeof() was being converted to pointer type. Instead, it should - be left alone, just like for sizeof. -
  • July 7, 2003: New Escape module provides utility functions - for escaping characters and strings in accordance with C lexical - rules.
    -
    -
  • July 2, 2003: Relax CIL's rules for when two enumeration types are -considered compatible. Previously CIL considered two enums to be compatible if -they were the same enum. Now we follow the C99 standard.
    -
    -
  • June 28, 2003: In the Formatparse module, Eric Haugh found and - fixed a bug in the handling of lvalues of the form “lv->field.more”.
    -
    -
  • June 28, 2003: Extended the handling of gcc command lines -arguments in the Perl scripts.
    -
    -
  • June 23, 2003: In Rmtmps module, simplified the API for - customizing the root set. Clients may supply a predicate that - returns true for each root global. Modifying various - “referenced” fields directly is no longer supported.
    -
    -
  • June 17, 2003: Reimplement internal utility routine - Cil.escape_char. Faster and better.
    -
    -
  • June 14, 2003: Implemented support for __attribute__s -appearing between "struct" and the struct tag name (also for unions and -enums), since gcc supports this as documented in section 4.30 of the gcc -(2.95.3) manual
    -
    -
  • May 30, 2003: Released the regression tests. -
  • May 28, 2003: Released version 1.1.2 -
  • May 26, 2003: Add the simplify module that compiles CIL -expressions into simpler expressions, similar to those that appear in a -3-address intermediate language. -
  • May 26, 2003: Various fixes and improvements to the pointer -analysis modules. -
  • May 26, 2003: Added optional consistency checking for -transformations. -
  • May 25, 2003: Added configuration support for big endian machines. -Now Cil.little_endian can be used to test whether the machine is -little endian or not. -
  • May 22, 2003: Fixed a bug in the handling of inline functions. The -CIL merger used to turn these functions into “static”, which is incorrect. -
  • May 22, 2003: Expanded the CIL consistency checker to verify -undesired sharing relationships between data structures. -
  • May 22, 2003: Fixed bug in the oneret CIL module: it was -mishandling certain labeled return statements. -
  • May 5, 2003: Released version 1.0.11 -
  • May 5, 2003: OS X (powerpc/darwin) support for CIL. Special -thanks to Jeff Foster, Andy Begel and Tim Leek. -
  • April 30, 2003: Better description of how to use CIL for your -analysis. -
  • April 28, 2003: Fixed a bug with --dooneRet and ---doheapify. Thanks, Manos Renieris. -
  • April 16, 2003: Reworked management of - temporary/intermediate output files in Perl driver scripts. Default - behavior is now to remove all such files. To keep intermediate - files, use one of the following existing flags: -
    • - --keepmerged for the single-file merge of all sources -
    • --keep=<dir> for various other CIL and - CCured output files -
    • --save-temps for various gcc intermediate files; MSVC - has no equivalent option -
    - As part of this change, some intermediate files have changed their - names slightly so that new suffixes are always preceded by a - period. For example, CCured output that used to appear in - “foocured.c” now appears in “foo.cured.c”. -
  • April 7, 2003: Changed the representation of the Cil.GVar -global constructor. Now it is possible to update the initializer without -reconstructing the global (which in turn it would require reconstructing the -list of globals that make up a program). We did this because it is often -tempting to use Cil.visitCilFileSameGlobals and the Cil.GVar -was the only global that could not be updated in place. -
  • April 6, 2003: Reimplemented parts of the cilly.pl script to make -it more robust in the presence of complex compiler arguments. -
  • March 10, 2003: Released version 1.0.9 -
  • March 10, 2003: Unified and documented a large number of CIL -Library Modules: oneret, simplemem, makecfg, heapify, stackguard, partial. -Also documented the main client interface for the pointer analysis. -
  • February 18, 2003: Fixed a bug in logwrites that was causing it -to produce invalid C code on writes to bitfields. Thanks, David Park. -
  • February 15, 2003: Released version 1.0.8 -
  • February 15, 2003: PDF versions of the manual and API are -available for those who would like to print them out. -
  • February 14, 2003: CIL now comes bundled with alias analyses. -
  • February 11, 2003: Added support for adding/removing options from - ./configure. -
  • February 3, 2003: Released version 1.0.7 -
  • February 1, 2003: Some bug fixes in the handling of variable -argument functions in new versions of gcc And glibc. -
  • January 29, 2003: Added the logical AND and OR operators. -Exapanded the translation to CIL to handle more complicated initializers -(including those that contain logical operators). -
  • January 28, 2003: Released version 1.0.6 -
  • January 28, 2003: Added support for the new handling of -variable-argument functions in new versions of glibc. -
  • January 19, 2003: Added support for declarations in interpreted - constructors. Relaxed the semantics of the patterns for variables. -
  • January 17, 2003: Added built-in prototypes for the gcc built-in - functions. Changed the pGlobal method in the printers to print the - carriage return as well. -
  • January 9, 2003: Reworked lexer and parser's strategy for - tracking source file names and line numbers to more closely match - typical native compiler behavior. The visible CIL interface is - unchanged. -
  • January 9, 2003: Changed the interface to the alpha convertor. Now -you can pass a list where it will record undo information that you can use to -revert the changes that it makes to the scope tables. -
  • January 6, 2003: Released version 1.0.5 -
  • January 4, 2003: Changed the interface for the Formatcil module. - Now the placeholders in the pattern have names. Also expanded the - documentation of the Formatcil module. - Now the placeholders in the pattern have names. -
  • January 3, 2003: Extended the rmtmps module to also remove - unused labels that are generated in the conversion to CIL. This reduces the - number of warnings that you get from cgcc afterwards. -
  • December 17, 2002: Fixed a few bugs in CIL related to the - representation of string literals. The standard says that a string literal - is an array. In CIL, a string literal has type pointer to character. This is - Ok, except as an argument of sizeof. To support this exception, we have - added to CIL the expression constructor SizeOfStr. This allowed us to fix - bugs with computing sizeof("foo bar") and sizeof((char*)"foo bar") - (the former is 8 and the latter is 4).
    -
    -
  • December 8, 2002: Fixed a few bugs in the lexer and parser - relating to hex and octal escapes in string literals. Also fixed - the dependencies between the lexer and parser. -
  • December 5, 2002: Fixed visitor bugs that were causing - some attributes not to be visited and some queued instructions to be - dropped. -
  • December 3, 2002: Added a transformation to catch stack - overflows. Fixed the heapify transformation. -
  • October 14, 2002: CIL is now available under the BSD license -(see the License section or the file LICENSE). Released version 1.0.4 -
  • October 9, 2002: More FreeBSD configuration changes, support -for the GCC-ims __signed and __volatile. Thanks to Axel -Simon for pointing out these problems. Released version 1.0.3 -
  • October 8, 2002: FreeBSD configuration and porting fixes. -Thanks to Axel Simon for pointing out these problems. -
  • September 10, 2002: Fixed bug in conversion to CIL. Now we drop -all “const” qualifiers from the types of locals, even from the fields of -local structures or elements of arrays. -
  • September 7, 2002: Extended visitor interface to distinguish visitng - offsets inside lvalues from offsets inside initializer lists. -
  • September 7, 2002: Released version 1.0.1 -
  • September 6, 2002: Extended the patcher with the ateof flag. -
  • September 4, 2002: Fixed bug in the elaboration to CIL. In some -cases constant folding of || and && was computed wrong. -
  • September 3, 2002: Fixed the merger documentation. -
  • August 29, 2002: Released version 1.0.0. -
  • August 29, 2002: Started numbering versions with a major nubmer, -minor and revisions. Released version 1.0.0. -
  • August 25, 2002: Fixed the implementation of the unique -identifiers for global variables and composites. Now those identifiers are -globally unique. -
  • August 24, 2002: Added to the machine-dependent configuration the -sizeofvoid. It is 1 on gcc and 0 on MSVC. Extended the implementation of -Cil.bitsSizeOf to handle this (it was previously returning an error when -trying to compute the size of void). -
  • August 24, 2002: Changed the representation of structure and -unions to distinguish between undefined structures and those that are defined -to be empty (allowed on gcc). The sizeof operator is undefined for the former -and returns 0 for the latter. -
  • August 22, 2002: Apply a patch from Richard H. Y. to support -FreeBSD installations. Thanks, Richard! -
  • August 12, 2002: Fixed a bug in the translation of wide-character -strings. Now this translation matches that of the underlying compiler. Changed -the implementation of the compiler dependencies. -
  • May 25, 2002: Added interpreted constructors and destructors. -
  • May 17, 2002: Changed the representation of functions to move the -“inline” information to the varinfo. This way we can print the “inline” -even in declarations which is what gcc does. -
  • May 15, 2002: Changed the visitor for initializers to make two -tail-recursive passes (the second is a List.rev and only done if one of -the initializers change). This prevents Stack_Overflow for large -initializers. Also improved the processing of initializers when converting to -CIL. -
  • May 15, 2002: Changed the front-end to allow the use of MSVC -mode even on machines that do not have MSVC. The machine-dependent parameters -for GCC will be used in that case. -
  • May 11, 2002: Changed the representation of formals in function -types. Now the function type is purely functional. -
  • May 4, 2002: Added the function -Cil.visitCilFileSameGlobals and changed Cil.visitCilFile to be -tail recursive. This prevents stack overflow on huge files. -
  • February 28, 2002: Changed the significance of the -CompoundInit in Cil.init to allow for missing initializers at the -end of an array initializer. Added the API function -Cil.foldLeftCompoundAll. -
-
-Previous -Up - - diff --git a/cil/doc/cil.css b/cil/doc/cil.css deleted file mode 100644 index 7466cf4..0000000 --- a/cil/doc/cil.css +++ /dev/null @@ -1,10 +0,0 @@ - -.toc{list-style:none;} -.title{margin:auto;text-align:center} -.center{text-align:center;margin-left:auto;margin-right:auto;} -.flushleft{text-align:left;margin-left:0ex;margin-right:auto;} -.flushright{text-align:right;margin-left:auto;margin-right:0ex;} -DIV TABLE{margin-left:inherit;margin-right:inherit;} -PRE{text-align:left;margin-left:0ex;margin-right:auto;} -BLOCKQUOTE{margin-left:4ex;margin-right:4ex;text-align:left;} -.part{margin:auto;text-align:center} diff --git a/cil/doc/cil.html b/cil/doc/cil.html deleted file mode 100644 index 4d912d3..0000000 --- a/cil/doc/cil.html +++ /dev/null @@ -1,3532 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - -

- - -

1  Introduction

- -New: CIL now has a Source Forge page: - http://sourceforge.net/projects/cil.
-
-CIL (C Intermediate Language) is a high-level representation -along with a set of tools that permit easy analysis and source-to-source -transformation of C programs.
-
-CIL is both lower-level than abstract-syntax trees, by clarifying ambiguous -constructs and removing redundant ones, and also higher-level than typical -intermediate languages designed for compilation, by maintaining types and a -close relationship with the source program. The main advantage of CIL is that -it compiles all valid C programs into a few core constructs with a very clean -semantics. Also CIL has a syntax-directed type system that makes it easy to -analyze and manipulate C programs. Furthermore, the CIL front-end is able to -process not only ANSI-C programs but also those using Microsoft C or GNU C -extensions. If you do not use CIL and want instead to use just a C parser and -analyze programs expressed as abstract-syntax trees then your analysis will -have to handle a lot of ugly corners of the language (let alone the fact that -parsing C itself is not a trivial task). See Section 16 for some -examples of such extreme programs that CIL simplifies for you.
-
-In essence, CIL is a highly-structured, “clean” subset of C. CIL features a -reduced number of syntactic and conceptual forms. For example, all looping -constructs are reduced to a single form, all function bodies are given -explicit return statements, syntactic sugar like "->" is -eliminated and function arguments with array types become pointers. (For an -extensive list of how CIL simplifies C programs, see Section 4.) -This reduces the number of cases that must be considered when manipulating a C -program. CIL also separates type declarations from code and flattens scopes -within function bodies. This structures the program in a manner more amenable -to rapid analysis and transformation. CIL computes the types of all program -expressions, and makes all type promotions and casts explicit. CIL supports -all GCC and MSVC extensions except for nested functions and complex numbers. -Finally, CIL organizes C's imperative features into expressions, instructions -and statements based on the presence and absence of side-effects and -control-flow. Every statement can be annotated with successor and predecessor -information. Thus CIL provides an integrated program representation that can -be used with routines that require an AST (e.g. type-based analyses and -pretty-printers), as well as with routines that require a CFG (e.g., dataflow -analyses). CIL also supports even lower-level representations (e.g., -three-address code), see Section 8.
-
-CIL comes accompanied by a number of Perl scripts that perform generally -useful operations on code: -
  • -A driver which behaves as either the gcc or -Microsoft VC compiler and can invoke the preprocessor followed by the CIL -application. The advantage of this script is that you can easily use CIL and -the analyses written for CIL with existing make files. -
  • A whole-program merger that you can use as a -replacement for your compiler and it learns all the files you compile when you -make a project and merges all of the preprocessed source files into a single -one. This makes it easy to do whole-program analysis. -
  • A patcher makes it easy to create modified -copies of the system include files. The CIL driver can then be told to use -these patched copies instead of the standard ones. -
-CIL has been tested very extensively. It is able to process the SPECINT95 -benchmarks, the Linux kernel, GIMP and other open-source projects. All of -these programs are compiled to the simple CIL and then passed to gcc and -they still run! We consider the compilation of Linux a major feat especially -since Linux contains many of the ugly GCC extensions (see Section 16.2). -This adds to about 1,000,000 lines of code that we tested it on. It is also -able to process the few Microsoft NT device drivers that we have had access -to. CIL was tested against GCC's c-torture testsuite and (except for the tests -involving complex numbers and inner functions, which CIL does not currently -implement) CIL passes most of the tests. Specifically CIL fails 23 tests out -of the 904 c-torture tests that it should pass. GCC itself fails 19 tests. A -total of 1400 regression test cases are run automatically on each change to -the CIL sources.
-
-CIL is relatively independent on the underlying machine and compiler. When -you build it CIL will configure itself according to the underlying compiler. -However, CIL has only been tested on Intel x86 using the gcc compiler on Linux -and cygwin and using the MS Visual C compiler. (See below for specific -versions of these compilers that we have used CIL for.)
-
-The largest application we have used CIL for is -CCured, a compiler that compiles C code into -type-safe code by analyzing your pointer usage and inserting runtime checks in -the places that cannot be guaranteed statically to be type safe.
-
-You can also use CIL to “compile” code that uses GCC extensions (e.g. the -Linux kernel) into standard C code.
-
-CIL also comes accompanies by a growing library of extensions (see -Section 8). You can use these for your projects or as examples of -using CIL.
-
-PDF versions of this manual and the -CIL API are available. However, we recommend the -HTML versions because the postprocessed code examples are easier to -view.
-
-If you use CIL in your project, we would appreciate letting us know. If you -want to cite CIL in your research writings, please refer to the paper “CIL: -Intermediate Language and Tools for Analysis and Transformation of C -Programs” by George C. Necula, Scott McPeak, S.P. Rahul and Westley Weimer, -in “Proceedings of Conference on Compilier Construction”, 2002.
-
- - -

2  Installation

- -You will need OCaml release 3.08 or higher to build CIL. CIL has been tested -on Linux and on Windows (where it can behave at either Microsoft Visual C or -gcc).
-
-If you want to use CIL on Windows then you must get a complete installation -of cygwin and the source-code OCaml distribution and compile it yourself -using the cygwin tools (as opposed to getting the Win32 native-code version of -OCaml). If you have not done this before then take a look -here. (Don't need to worry about cvs and -ssh unless you will need to use the master CVS repository for CIL.) -
  1. -Download the CIL distribution (latest version is -distrib/cil-1.3.5.tar.gz). See the Section 20 for recent changes to the CIL distribution. -
  2. Unzip and untar the source distribution. This will create a directory - called cil whose structure is explained below.
    -tar xvfz cil-1.3.5.tar.gz -
  3. Enter the cil directory and run the configure script and then - GNU make to build the distribution. If you are on Windows, at least the - configure step must be run from within bash.
    -    cd cil
    -    ./configure
    -    make
    -    make quicktest
    -
  4. You should now find cilly.asm.exe in a -subdirectory of obj. The name of the subdirectory is either x86_WIN32 -if you are using cygwin on Windows or x86_LINUX if you are using -Linux (although you should be using instead the Perl wrapper bin/cilly). -Note that we do not have an install make target and you should use Cil -from the development directory. -
  5. If you decide to use CIL, please -send us a note. This will help recharge -our batteries after more than a year of development. And of course, do send us -your bug reports as well.
-The configure script tries to find appropriate defaults for your system. -You can control its actions by passing the following arguments: -
  • -CC=foo Specifies the path for the gcc executable. By default -whichever version is in the PATH is used. If CC specifies the Microsoft -cl compiler, then that compiler will be set as the default one. Otherwise, -the gcc compiler will be the default. -
-CIL requires an underlying C compiler and preprocessor. CIL depends on the -underlying compiler and machine for the sizes and alignment of types.The -installation procedure for CIL queries the underlying compiler for -architecture and compiler dependent configuration parameters, such as the size -of a pointer or the particular alignment rules for structure fields. (This -means, of course, that you should re-run ./configure when you move CIL to -another machine.)
-
-We have tested CIL on the following compilers: -
  • -On Windows, cl compiler version 12.00.8168 (MSVC 6), - 13.00.9466 (MSVC .Net), and 13.10.3077 (MSVC .Net 2003). Run cl - with no arguments to get the compiler version. -
  • On Windows, using cygwin and gcc version 2.95.3, 3.0, - 3.2, 3.3, and 3.4. -
  • On Linux, using gcc version 2.95.3, 3.0, 3.2, 3.3, and 4.0. -
-Others have successfully used CIL with Mac OS X (on both PowerPC and -x86), Solaris, and *BSD. If you make any changes to the build -system in order to run CIL on your platform, please send us a patch.
-
- - -

3  Distribution Contents

- -The file distrib/cil-1.3.5.tar.gz -contains the complete source CIL distribution, -consisting of the following files:
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
FilenameDescription
Makefile.inconfigure source for the - Makefile that builds CIL
configureThe configure script
configure.inThe autoconf source for configure
config.guess, config.sub, install-shstuff required by - configure
 
doc/HTML documentation of the CIL API
obj/Directory that will contain the compiled - CIL modules and executables
bin/cilly.inThe configure source for a Perl script - that can be invoked with the - same arguments as either gcc or - Microsoft Visual C and will convert the - program to CIL, perform some simple - transformations, emit it and compile it as - usual.
lib/CompilerStub.pmA Perl class that can be used to write code - that impersonates a compiler. cilly - uses it.
lib/Merger.pmA subclass of CompilerStub.pm that can - be used to merge source files into a single - source file.cilly - uses it.
bin/patcher.inA Perl script that applies specified patches - to standard include files.
 
src/check.ml,mliChecks the well-formedness of a CIL file
src/cil.ml,mliDefinition of CIL abstract syntax and - utilities for manipulating it
src/clist.ml,mliUtilities for efficiently managing lists - that need to be concatenated often
src/errormsg.ml,mliUtilities for error reporting
src/ext/heapify.mlA CIL transformation that moves array local - variables from the stack to the heap
src/ext/logcalls.ml,mliA CIL transformation that logs every - function call
src/ext/sfi.mlA CIL transformation that can log every - memory read and write
src/frontc/clexer.mllThe lexer
src/frontc/cparser.mlyThe parser
src/frontc/cabs.mlThe abstract syntax
src/frontc/cprint.mlThe pretty printer for CABS
src/frontc/cabs2cil.mlThe elaborator to CIL
src/main.mlThe cilly application
src/pretty.ml,mliUtilities for pretty printing
src/rmtmps.ml,mliA CIL tranformation that removes unused - types, variables and inlined functions
src/stats.ml,mliUtilities for maintaining timing statistics
src/testcil.mlA random test of CIL (against the resident - C compiler)
src/trace.ml,mliUtilities useful for printing debugging - information
 
ocamlutil/Miscellaneous libraries that are not - specific to CIL.
ocamlutil/Makefile.ocamlA file that is included by Makefile
ocamlutil/Makefile.ocaml.buildA file that is included by Makefile
ocamlutil/perfcount.cC code that links with src/stats.ml - and reads Intel performance - counters.
 
obj/@ARCHOS@/feature_config.mlFile generated by the Makefile - describing which extra “features” - to compile. See Section 5
obj/@ARCHOS@/machdep.mlFile generated by the Makefile containing - information about your architecture, - such as the size of a pointer
src/machdep.cC program that generates - machdep.ml files

- - -

4  Compiling C to CIL

- -In this section we try to describe a few of the many transformations that are -applied to a C program to convert it to CIL. The module that implements this -conversion is about 5000 lines of OCaml code. In contrast a simple program -transformation that instruments all functions to keep a shadow stack of the -true return address (thus preventing stack smashing) is only 70 lines of code. -This example shows that the analysis is so much simpler because it has to -handle only a few simple C constructs and also because it can leverage on CIL -infrastructure such as visitors and pretty-printers.
-
-In no particular order these are a few of the most significant ways in which -C programs are compiled into CIL: -
  1. -CIL will eliminate all declarations for unused entities. This means that -just because your hello world program includes stdio.h it does not mean -that your analysis has to handle all the ugly stuff from stdio.h.
    -
    -
  2. Type specifiers are interpreted and normalized: -
    
-int long signed x;
-signed long extern x;
-long static int long y;
-
-// Some code that uses these declaration, so that CIL does not remove them
-int main() { return x + y; }
-
    -See the CIL output for this -code fragment
    -
    -
  3. Anonymous structure and union declarations are given a name. -
    
- struct { int x; } s;
-
    -See the CIL output for this -code fragment
    -
    -
  4. Nested structure tag definitions are pulled apart. This means that all -structure tag definitions can be found by a simple scan of the globals. -
    
-struct foo {
-   struct bar {
-      union baz { 
-          int x1; 
-          double x2;
-      } u1;
-      int y;
-   } s1;
-   int z;
-} f;
-
    -See the CIL output for this -code fragment
    -
    -
  5. All structure, union, enumeration definitions and the type definitions -from inners scopes are moved to global scope (with appropriate renaming). This -facilitates moving around of the references to these entities. -
    
-int main() {
-  struct foo { 
-        int x; } foo; 
-  {
-     struct foo { 
-        double d;
-     };
-     return foo.x;
-  }      
-}
-
    -See the CIL output for this -code fragment
    -
    -
  6. Prototypes are added for those functions that are called before being -defined. Furthermore, if a prototype exists but does not specify the type of -parameters that is fixed. But CIL will not be able to add prototypes for those -functions that are neither declared nor defined (but are used!). -
    
-  int f();  // Prototype without arguments
-  int f(double x) {
-      return g(x);
-  }
-  int g(double x) {
-     return x;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  7. Array lengths are computed based on the initializers or by constant -folding. -
    
-  int a1[] = {1,2,3};
-  int a2[sizeof(int) >= 4 ? 8 : 16];
-
    -See the CIL output for this -code fragment
    -
    -
  8. Enumeration tags are computed using constant folding: -
    
-int main() {
-  enum { 
-     FIVE = 5, 
-     SIX, SEVEN, 
-     FOUR = FIVE - 1, 
-     EIGHT = sizeof(double)
-  } x = FIVE;
- return x;
-}
-
-
    -See the CIL output for this -code fragment
    -
    -
  9. Initializers are normalized to include specific initialization for the -missing elements: -
    
-  int a1[5] = {1,2,3};
-  struct foo { int x, y; } s1 = { 4 };
-
    -See the CIL output for this -code fragment
    -
    -
  10. Initializer designators are interpreted and eliminated. Subobjects are -properly marked with braces. CIL implements -the whole ISO C99 specification for initializer (neither GCC nor MSVC do) and -a few GCC extensions. -
    
-  struct foo { 
-     int x, y; 
-     int a[5];
-     struct inner {
-        int z;
-     } inner;
-  } s = { 0, .inner.z = 3, .a[1 ... 2] = 5, 4, y : 8 };
-
    -See the CIL output for this -code fragment
    -
    -
  11. String initializers for arrays of characters are processed -
    
-char foo[] = "foo plus bar";
-
    -See the CIL output for this -code fragment
    -
    -
  12. String constants are concatenated -
    
-char *foo = "foo " " plus " " bar ";
-
    -See the CIL output for this -code fragment
    -
    -
  13. Initializers for local variables are turned into assignments. This is in -order to separate completely the declarative part of a function body from the -statements. This has the unfortunate effect that we have to drop the const -qualifier from local variables ! -
    
-  int x = 5; 
-  struct foo { int f1, f2; } a [] = {1, 2, 3, 4, 5 };
-
    -See the CIL output for this -code fragment
    -
    -
  14. Local variables in inner scopes are pulled to function scope (with -appropriate renaming). Local scopes thus disappear. This makes it easy to find -and operate on all local variables in a function. -
    
-  int x = 5; 
-  int main() {
-    int x = 6;
-    { 
-      int x = 7;
-      return x;
-    }
-    return x;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  15. Global declarations in local scopes are moved to global scope: -
    
-  int x = 5; 
-  int main() {
-    int x = 6;
-    { 
-      static int x = 7;
-      return x;
-    }
-    return x;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  16. Return statements are added for functions that are missing them. If the -return type is not a base type then a return without a value is added. -The guaranteed presence of return statements makes it easy to implement a -transformation that inserts some code to be executed immediately before -returning from a function. -
    
-  int foo() {
-    int x = 5;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  17. One of the most significant transformations is that expressions that -contain side-effects are separated into statements. -
    
-   int x, f(int);
-   return (x ++ + f(x));
-
    -See the CIL output for this -code fragment
    -
    -Internally, the x ++ statement is turned into an assignment which the -pretty-printer prints like the original. CIL has only three forms of basic -statements: assignments, function calls and inline assembly.
    -
    -
  18. Shortcut evaluation of boolean expressions and the ?: operator are -compiled into explicit conditionals: -
    
-  int x;
-  int y = x ? 2 : 4;
-  int z = x || y;
-  // Here we duplicate the return statement
-  if(x && y) { return 0; } else { return 1; }
-  // To avoid excessive duplication, CIL uses goto's for 
-  // statement that have more than 5 instructions
-  if(x && y || z) { x ++; y ++; z ++; x ++; y ++; return z; }
-
    -See the CIL output for this -code fragment
    -
    -
  19. GCC's conditional expression with missing operands are also compiled -into conditionals: -
    
-  int f();;
-  return f() ? : 4;
-
    -See the CIL output for this -code fragment
    -
    -
  20. All forms of loops (while, for and do) are compiled -internally as a single while(1) looping construct with explicit break -statement for termination. For simple while loops the pretty printer is -able to print back the original: -
    
-   int x, y;
-   for(int i = 0; i<5; i++) {
-      if(i == 5) continue;
-      if(i == 4) break;
-      i += 2;
-   } 
-   while(x < 5) {
-     if(x == 3) continue;
-     x ++;
-   }
-
    -See the CIL output for this -code fragment
    -
    -
  21. GCC's block expressions are compiled away. (That's right there is an -infinite loop in this code.) -
    
-   int x = 5, y = x;
-   int z = ({ x++; L: y -= x; y;});
-   return ({ goto L; 0; });
-
    -See the CIL output for this -code fragment
    -
    -
  22. CIL contains support for both MSVC and GCC inline assembly (both in one -internal construct)
    -
    -
  23. CIL compiles away the GCC extension that allows many kinds of constructs -to be used as lvalues: -
    
-   int x, y, z;
-   return &(x ? y : z) - & (x ++, x);
-
    -See the CIL output for this -code fragment
    -
    -
  24. All types are computed and explicit casts are inserted for all -promotions and conversions that a compiler must insert:
    -
    -
  25. CIL will turn old-style function definition (without prototype) into -new-style definitions. This will make the compiler less forgiving when -checking function calls, and will catch for example cases when a function is -called with too few arguments. This happens in old-style code for the purpose -of implementing variable argument functions.
    -
    -
  26. Since CIL sees the source after preprocessing the code after CIL does -not contain the comments and the preprocessing directives.
    -
    -
  27. CIL will remove from the source file those type declarations, local -variables and inline functions that are not used in the file. This means that -your analysis does not have to see all the ugly stuff that comes from the -header files: -
    
-#include <stdio.h>
-
-typedef int unused_type;
-
-static char unused_static (void) { return 0; }
-
-int main() {
-  int unused_local;
-  printf("Hello world\n"); // Only printf will be kept from stdio.h     
-}
-
    -See the CIL output for this -code fragment
- - -

5  How to Use CIL

- -
-
-There are two predominant ways to use CIL to write a program analysis or -transformation. The first is to phrase your analysis as a module that is -called by our existing driver. The second is to use CIL as a stand-alone -library. We highly recommend that you use cilly, our driver.
-
- - -

5.1  Using cilly, the CIL driver

- -The most common way to use CIL is to write an Ocaml module containing your -analysis and transformation, which you then link into our boilerplate -driver application called cilly. cilly is a Perl script that -processes and mimics GCC and MSVC command-line arguments and then -calls cilly.byte.exe or cilly.asm.exe (CIL's Ocaml executable).
-
-An example of such module is logwrites.ml, a transformation that is -distributed with CIL and whose purpose is to instrument code to print the -addresses of memory locations being written. (We plan to release a -C-language interface to CIL so that you can write your analyses in C -instead of Ocaml.) See Section 8 for a survey of other example -modules.
-
-Assuming that you have written /home/necula/logwrites.ml, -here is how you use it: -
  1. Modify logwrites.ml so that it includes a CIL “feature - descriptor” like this: -
    -let feature : featureDescr = 
-  { fd_name = "logwrites";              
-    fd_enabled = ref false;
-    fd_description = "generation of code to log memory writes";
-    fd_extraopt = [];
-    fd_doit = 
-    (function (f: file) -> 
-      let lwVisitor = new logWriteVisitor in
-      visitCilFileSameGlobals lwVisitor f)
-  } 
-
    The fd_name field names the feature and its associated - command-line arguments. The fd_enabled field is a bool ref. - “fd_doit” will be invoked if !fd_enabled is true after - argument parsing, so initialize the ref cell to true if you want - this feature to be enabled by default.
    -
    -When the user passes the --dologwrites - command-line option to cilly, the variable associated with the - fd_enabled flag is set and the fd_doit function is called - on the Cil.file that represents the merger (see Section 13) of - all C files listed as arguments.
    -
    -
  2. Invoke configure with the arguments -
    -./configure EXTRASRCDIRS=/home/necula EXTRAFEATURES=logwrites
-
    - This step works if each feature is packaged into its own ML file, and the -name of the entry point in the file is feature.
    -
    -An alternative way to specify the new features is to change the build files -yourself, as explained below. You'll need to use this method if a single -feature is split across multiple files. -
    1. - Put logwrites.ml in the src or src/ext directory. This - will make sure that make can find it. If you want to put it in some - other directory, modify Makefile.in and add to SOURCEDIRS your - directory. Alternately, you can create a symlink from src or - src/ext to your file.
      -
      -
    2. Modify the Makefile.in and add your module to the - CILLY_MODULES or - CILLY_LIBRARY_MODULES variables. The order of the modules matters. Add - your modules somewhere after cil and before main.
      -
      -
    3. If you have any helper files for your module, add those to - the makefile in the same way. e.g.: -
      -CILLY_MODULES = $(CILLY_LIBRARY_MODULES) \
-                myutilities1 myutilities2 logwrites \
-                main
-
      - Again, order is important: myutilities2.ml will be able to refer - to Myutilities1 but not Logwrites. If you have any ocamllex or ocamlyacc - files, add them to both CILLY_MODULES and either MLLS or - MLYS.
      -
      -
    4. Modify main.ml so that your new feature descriptor appears in - the global list of CIL features. -
      -let features : C.featureDescr list = 
-  [ Logcalls.feature;
-    Oneret.feature;    
-    Heapify.feature1;  
-    Heapify.feature2;
-    makeCFGFeature; 
-    Partial.feature;
-    Simplemem.feature;
-    Logwrites.feature;  (* add this line to include the logwrites feature! *)
-  ] 
-  @ Feature_config.features 
-
      - Features are processed in the order they appear on this list. Put - your feature last on the list if you plan to run any of CIL's - built-in features (such as makeCFGfeature) before your own.

    -Standard code in cilly takes care of adding command-line arguments, - printing the description, and calling your function automatically. - Note: do not worry about introducing new bugs into CIL by adding a single - line to the feature list.
    -
    -
  3. Now you can invoke the cilly application on a preprocessed file, or - instead use the cilly driver which provides a convenient compiler-like - interface to cilly. See Section 7 for details using cilly. - Remember to enable your analysis by passing the right argument (e.g., - --dologwrites).
- - -

5.2  Using CIL as a library

- -CIL can also be built as a library that is called from your stand-alone -application. Add cil/src, cil/src/frontc, cil/obj/x86_LINUX -(or cil/obj/x86_WIN32) to your Ocaml project -I include paths. -Building CIL will also build the library cil/obj/*/cil.cma (or -cil/obj/*/cil.cmxa). You can then link your application against that -library.
-
-You can call the Frontc.parse: string -> unit -> Cil.file function with -the name of a file containing the output of the C preprocessor. -The Mergecil.merge: Cil.file list -> string -> Cil.file function merges -multiple files. You can then invoke your analysis function on the resulting -Cil.file data structure. You might want to call -Rmtmps.removeUnusedTemps first to clean up the prototypes and variables -that are not used. Then you can call the function Cil.dumpFile: -cilPrinter -> out_channel -> Cil.file -> unit to print the file to a -given output channel. A good cilPrinter to use is -defaultCilPrinter.
-
-Check out src/main.ml and bin/cilly for other good ideas -about high-level file processing. Again, we highly recommend that you just -our cilly driver so that you can avoid spending time re-inventing the -wheel to provide drop-in support for standard makefiles.
-
-Here is a concrete example of compiling and linking your project against -CIL. Imagine that your program analysis or transformation is contained in -the single file main.ml. -
-$ ocamlopt -c -I $(CIL)/obj/x86_LINUX/ main.ml
-$ ocamlopt -ccopt -L$(CIL)/obj/x86_LINUX/ -o main unix.cmxa str.cmxa \ 
-        $(CIL)/obj/x86_LINUX/cil.cmxa main.cmx
-
-The first line compiles your analysis, the second line links it against CIL -(as a library) and the Ocaml Unix library. For more information about -compiling and linking Ocaml programs, see the Ocaml home page -at http://caml.inria.fr/ocaml/.
-
-In the next section we give an overview of the API that you can use -to write your analysis and transformation.
-
- - -

6  CIL API Documentation

- -The CIL API is documented in the file src/cil.mli. We also have an -online documentation extracted from cil.mli. We -index below the main types that are used to represent C programs in CIL: - - - -

6.1  Using the visitor

- -One of the most useful tools exported by the CIL API is an implementation of -the visitor pattern for CIL programs. The visiting engine scans depth-first -the structure of a CIL program and at each node is queries a user-provided -visitor structure whether it should do one of the following operations: -
  • -Ignore this node and all its descendants -
  • Descend into all of the children and when done rebuild the node if any -of the children have changed. -
  • Replace the subtree rooted at the node with another tree. -
  • Replace the subtree with another tree, then descend into the children -and rebuild the node if necessary and then invoke a user-specified function. -
  • In addition to all of the above actions then visitor can specify that -some instructions should be queued to be inserted before the current -instruction or statement being visited. -
-By writing visitors you can customize the program traversal and -transformation. One major limitation of the visiting engine is that it does -not propagate information from one node to another. Each visitor must use its -own private data to achieve this effect if necessary.
-
-Each visitor is an object that is an instance of a class of type Cil.cilVisitor.. -The most convenient way to obtain such classes is to specialize the -Cil.nopCilVisitor.class (which just traverses the tree doing -nothing). Any given specialization typically overrides only a few of the -methods. Take a look for example at the visitor defined in the module -logwrites.ml. Another, more elaborate example of a visitor is the -[copyFunctionVisitor] defined in cil.ml.
-
-Once you have defined a visitor you can invoke it with one of the functions: - -Some transformations may want to use visitors to insert additional -instructions before statements and instructions. To do so, pass a list of -instructions to the Cil.queueInstr method of the specialized -object. The instructions will automatically be inserted before that -instruction in the transformed code. The Cil.unqueueInstr method -should not normally be called by the user.
-
- - -

6.2  Interpreted Constructors and Deconstructors

- -Interpreted constructors and deconstructors are a facility for constructing -and deconstructing CIL constructs using a pattern with holes that can be -filled with a variety of kinds of elements. The pattern is a string that uses -the C syntax to represent C language elements. For example, the following -code: -

-Formatcil.cType "void * const (*)(int x)"
-
-is an alternative way to construct the internal representation of the type of pointer to function -with an integer argument and a void * const as result: -

-TPtr(TFun(TVoid [Attr("const", [])],
-          [ ("x", TInt(IInt, []), []) ], false, []), [])
-
-The advantage of the interpreted constructors is that you can use familiar C -syntax to construct CIL abstract-syntax trees.
-
-You can construct this way types, lvalues, expressions, instructions and -statements. The pattern string can also contain a number of placeholders that -are replaced during construction with CIL items passed as additional argument -to the construction function. For example, the %e:id placeholder means -that the argument labeled “id” (expected to be of form Fe exp) will -supply the expression to replace the placeholder. For example, the following -code constructs an increment instruction at location loc: -

-Formatcil.cInstr "%v:x = %v:x + %e:something"
-        loc
-        [ ("something", Fe some_exp);
-          ("x", Fv some_varinfo) ]
-
-An alternative way to construct the same CIL instruction is: -

-Set((Var some_varinfo, NoOffset),
-    BinOp(PlusA, Lval (Var some_varinfo, NoOffset),
-          some_exp, intType), 
-    loc)
-
-See Cil.formatArg for a definition of the placeholders that are -understood.
-
-A dual feature is the interpreted deconstructors. This can be used to test -whether a CIL construct has a certain form: -

-Formatcil.dType "void * const (*)(int x)" t
-
-will test whether the actual argument t is indeed a function pointer of -the required type. If it is then the result is Some [] otherwise it is -None. Furthermore, for the purpose of the interpreted deconstructors -placeholders in patterns match anything of the right type. For example, -

-Formatcil.dType "void * (*)(%F:t)" t
-
-will match any function pointer type, independent of the type and number of -the formals. If the match succeeds the result is Some [ FF forms ] where -forms is a list of names and types of the formals. Note that each member -in the resulting list corresponds positionally to a placeholder in the -pattern.
-
-The interpreted constructors and deconstructors do not support the complete C -syntax, but only a substantial fragment chosen to simplify the parsing. The -following is the syntax that is supported: -
-Expressions:
-  E ::= %e:ID | %d:ID | %g:ID | n | L | ( E ) | Unop E | E Binop E 
-        | sizeof E | sizeof ( T ) | alignof E  | alignof ( T ) 
-        | & L | ( T ) E 
-
-Unary operators:
-  Unop ::= + | - | ~ | %u:ID
-
-Binary operators:
-  Binop ::= + | - | * | / | << | >> | & | ``|'' | ^ 
-          | == | != | < | > | <= | >= | %b:ID
-
-Lvalues:
-  L ::= %l:ID | %v:ID Offset | * E | (* E) Offset | E -> ident Offset 
-
-Offsets:
-  Offset ::= empty | %o:ID | . ident Offset | [ E ] Offset
-
-Types:
-  T ::= Type_spec Attrs Decl
-
-Type specifiers:
-  Type_spec ::= void | char | unsigned char | short | unsigned short
-            | int | unsigned int | long | unsigned long | %k:ID | float 
-            | double | struct %c:ID | union %c:ID 
-
-
-Declarators:
-  Decl ::= * Attrs Decl | Direct_decl
-
-
-Direct declarators:
-  Direct_decl ::= empty | ident | ( Attrs Decl ) 
-                 | Direct_decl [ Exp_opt ]
-                 | ( Attrs Decl )( Parameters )
-
-Optional expressions
-  Exp_opt ::= empty | E | %eo:ID
-
-Formal parameters
-  Parameters ::= empty | ... | %va:ID | %f:ID | T | T , Parameters
-
-List of attributes
-  Attrs ::= empty | %A:ID | Attrib Attrs
-
-Attributes
-  Attrib ::= const | restrict | volatile | __attribute__ ( ( GAttr ) )
-
-GCC Attributes
-  GAttr ::= ident | ident ( AttrArg_List )
-
-Lists of GCC Attribute arguments:
-  AttrArg_List ::= AttrArg | %P:ID | AttrArg , AttrArg_List
-
-GCC Attribute arguments  
-  AttrArg ::= %p:ID | ident | ident ( AttrArg_List )
-
-Instructions
-  Instr ::= %i:ID ; | L = E ; | L Binop= E | Callres L ( Args )
-
-Actual arguments
-   Args ::= empty | %E:ID | E | E , Args
-
-Call destination
-   Callres ::= empty | L = | %lo:ID
-
-Statements
-  Stmt ::= %s:ID | if ( E ) then Stmt ; | if ( E ) then Stmt else Stmt ;
-       | return Exp_opt | break ; | continue ; | { Stmt_list } 
-       | while (E ) Stmt | Instr_list 
-
-Lists of statements
-   Stmt_list ::= empty | %S:ID | Stmt Stmt_list  
-                | Type_spec Attrs Decl ; Stmt_list
-                | Type_spec Attrs Decl = E ; Stmt_list
-                | Type_spec Attrs Decl = L (Args) ; Stmt_list
-
-List of instructions
-   Instr_list ::= Instr | %I:ID | Instr Instr_list
-
-Notes regarding the syntax: -
  • -In the grammar description above non-terminals are written with -uppercase initial
    -
    -
  • All of the patterns consist of the % character followed by one or -two letters, followed by “:” and an indentifier. For each such -pattern there is a corresponding constructor of the Cil.formatArg -type, whose name is the letter 'F' followed by the same one or two letters as -in the pattern. That constructor is used by the user code to pass a -Cil.formatArg actual argument to the interpreted constructor and by -the interpreted deconstructor to return what was matched for a pattern.
    -
    -
  • If the pattern name is uppercase, it designates a list of the elements -designated by the corresponding lowercase pattern. E.g. %E designated lists -of expressions (as in the actual arguments of a call).
    -
    -
  • The two-letter patterns whose second letter is “o” designate an -optional element. E.g. %eo designates an optional expression (as in the -length of an array).
    -
    -
  • Unlike in calls to printf, the pattern %g is used for strings.
    -
    -
  • The usual precedence and associativity rules as in C apply
    -
    -
  • The pattern string can contain newlines and comments, using both the -/* ... */ style as well as the // one.
    -
    -
  • When matching a “cast” pattern of the form ( T ) E, the -deconstructor will match even expressions that do not have the actual cast but -in that case the type is matched against the type of the expression. E.g. the -patters "(int)%e" will match any expression of type int whether it -has an explicit cast or not.
    -
    -
  • The %k pattern is used to construct and deconstruct an integer type of -any kind.
    -
    -
  • Notice that the syntax of types and declaration are the same (in order -to simplify the parser). This means that technically you can write a whole -declaration instead of a type in the cast. In this case the name that you -declare is ignored.
    -
    -
  • In lists of formal parameters and lists of attributes, an empty list in -the pattern matches any formal parameters or attributes.
    -
    -
  • When matching types, uses of named types are unrolled to expose a real -type before matching.
    -
    -
  • The order of the attributes is ignored during matching. The the pattern -for a list of attributes contains %A then the resulting formatArg will be -bound to all attributes in the list. For example, the pattern "const -%A" matches any list of attributes that contains const and binds the -corresponding placeholder to the entire list of attributes, including -const.
    -
    -
  • All instruction-patterns must be terminated by semicolon
    -
    -
  • The autoincrement and autodecrement instructions are not supported. Also -not supported are complex expressions, the && and || shortcut -operators, and a number of other more complex instructions or statements. In -general, the patterns support only constructs that can be represented directly -in CIL.
    -
    -
  • The pattern argument identifiers are not used during deconstruction. -Instead, the result contains a sequence of values in the same order as the -appearance of pattern arguments in the pattern.
    -
    -
  • You can mix statements with declarations. For each declaration a new - temporary will be constructed (using a function you provive). You can then - refer to that temporary by name in the rest of the pattern.
    -
    -
  • The %v: pattern specifier is optional. -
-The following function are defined in the Formatcil module for -constructing and deconstructing: - -Below is an example using interpreted constructors. This example generates -the CIL representation of code that scans an array backwards and initializes -every even-index element with an expression: -

-Formatcil.cStmts
-  loc
-  "int idx = sizeof(array) / sizeof(array[0]) - 1;
-   while(idx >= 0) {
-     // Some statements to be run for all the elements of the array
-     %S:init
-     if(! (idx & 1)) 
-       array[idx] = %e:init_even;
-     /* Do not forget to decrement the index variable */
-     idx = idx - 1;
-   }"
-  (fun n t -> makeTempVar myfunc ~name:n t)
-  [ ("array", Fv myarray); 
-    ("init", FS [stmt1; stmt2; stmt3]);
-    ("init_even", Fe init_expr_for_even_elements) ]
-
-To write the same CIL statement directly in CIL would take much more effort. -Note that the pattern is parsed only once and the result (a function that -takes the arguments and constructs the statement) is memoized.
-
- - -

6.2.1  Performance considerations for interpreted constructors

- -Parsing the patterns is done with a LALR parser and it takes some time. To -improve performance the constructors and deconstructors memoize the parsed -patterns and will only compile a pattern once. Also all construction and -deconstruction functions can be applied partially to the pattern string to -produce a function that can be later used directly to construct or -deconstruct. This function appears to be about two times slower than if the -construction is done using the CIL constructors (without memoization the -process would be one order of magnitude slower.) However, the convenience of -interpreted constructor might make them a viable choice in many situations -when performance is not paramount (e.g. prototyping).
-
- - -

6.3  Printing and Debugging support

- -The Modules Pretty and Errormsg contain respectively -utilities for pretty printing and reporting errors and provide a convenient -printf-like interface.
-
-Additionally, CIL defines for each major type a pretty-printing function that -you can use in conjunction with the Pretty interface. The -following are some of the pretty-printing functions: - -You can even customize the pretty-printer by creating instances of -Cil.cilPrinter.. Typically such an instance extends -Cil.defaultCilPrinter. Once you have a customized pretty-printer you -can use the following printing functions: - -CIL has certain internal consistency invariants. For example, all references -to a global variable must point to the same varinfo structure. This -ensures that one can rename the variable by changing the name in the -varinfo. These constraints are mentioned in the API documentation. There -is also a consistency checker in file src/check.ml. If you suspect that -your transformation is breaking these constraints then you can pass the ---check option to cilly and this will ensure that the consistency checker -is run after each transformation.
-
- - -

6.4  Attributes

- -In CIL you can attach attributes to types and to names (variables, functions -and fields). Attributes are represented using the type Cil.attribute. -An attribute consists of a name and a number of arguments (represented using -the type Cil.attrparam). Almost any expression can be used as an -attribute argument. Attributes are stored in lists sorted by the name of the -attribute. To maintain list ordering, use the functions -Cil.typeAttrs to retrieve the attributes of a type and the functions -Cil.addAttribute and Cil.addAttributes to add attributes. -Alternatively you can use Cil.typeAddAttributes to add an attribute to -a type (and return the new type).
-
-GCC already has extensive support for attributes, and CIL extends this -support to user-defined attributes. A GCC attribute has the syntax: -
- gccattribute ::= __attribute__((attribute))    (Note the double parentheses)
-
- Since GCC and MSVC both support various flavors of each attribute (with or -without leading or trailing _) we first strip ALL leading and trailing _ -from the attribute name (but not the identified in [ACons] parameters in -Cil.attrparam). When we print attributes, for GCC we add two leading -and two trailing _; for MSVC we add just two leading _.
-
-There is support in CIL so that you can control the printing of attributes -(see Cil.setCustomPrintAttribute and -Cil.setCustomPrintAttributeScope). This custom-printing support is now -used to print the "const" qualifier as "const" and not as -"__attribute__((const))".
-
-The attributes are specified in declarations. This is unfortunate since the C -syntax for declarations is already quite complicated and after writing the -parser and elaborator for declarations I am convinced that few C programmers -understand it completely. Anyway, this seems to be the easiest way to support -attributes.
-
-Name attributes must be specified at the very end of the declaration, just -before the = for the initializer or before the , the separates a -declaration in a group of declarations or just before the ; that -terminates the declaration. A name attribute for a function being defined can -be specified just before the brace that starts the function body.
-
-For example (in the following examples A1,...,An are type attributes -and N is a name attribute (each of these uses the __attribute__ syntax): -

- int x N;
- int x N, * y N = 0, z[] N;
- extern void exit() N;
- int fact(int x) N { ... }
-
-Type attributes can be specified along with the type using the following - rules: -
  1. - The type attributes for a base type (int, float, named type, reference - to struct or union or enum) must be specified immediately following the - type (actually it is Ok to mix attributes with the specification of the - type, in between unsigned and int for example).
    -
    -For example: -
    
-  int A1 x N;  /* A1 applies to the type int. An example is an attribute
-                   "even" restricting the type int to even values. */
-  struct foo A1 A2 x; // Both A1 and A2 apply to the struct foo type
-

    -
    -
  2. The type attributes for a pointer type must be specified immediately - after the * symbol. -
    
- /* A pointer (A1) to an int (A2) */
- int A2 * A1 x;
- /* A pointer (A1) to a pointer (A2) to a float (A3) */
- float A3 * A2 * A1 x;
-
    -Note: The attributes for base types and for pointer types are a strict - extension of the ANSI C type qualifiers (const, volatile and restrict). In - fact CIL treats these qualifiers as attributes.
    -
    -
  3. The attributes for a function type or for an array type can be - specified using parenthesized declarators.
    -
    -For example: -
    
-   /* A function (A1) from int (A2) to float (A3) */
-   float A3 (A1 f)(int A2);
-
-   /* A pointer (A1) to a function (A2) that returns an int (A3) */
-   int A3 (A2 * A1 pfun)(void);
-
-   /* An array (A1) of int (A2) */
-   int A2 (A1 x0)[]
-
-   /* Array (A1) of pointers (A2) to functions (A3) that take an int (A4) and 
-    * return a pointer (A5) to int (A6)  */
-   int A6 * A5 (A3 * A2 (A1 x1)[5])(int A4);
-
-
-   /* A function (A4) that takes a float (A5) and returns a pointer (A6) to an 
-    * int (A7) */
-   extern int A7 * A6 (A4 x2)(float A5 x);
-
-   /* A function (A1) that takes a int (A2) and that returns a pointer (A3) to 
-    * a function (A4) that takes a float (A5) and returns a pointer (A6) to an 
-    * int (A7) */
-   int A7 * A6 (A4 * A3 (A1 x3)(int A2 x))(float A5) {
-      return & x2;
-   }
-
-Note: ANSI C does not allow the specification of type qualifiers for function -and array types, although it allows for the parenthesized declarator. With -just a bit of thought (looking at the first few examples above) I hope that -the placement of attributes for function and array types will seem intuitive.
-
-This extension is not without problems however. If you want to refer just to -a type (in a cast for example) then you leave the name out. But this leads to -strange conflicts due to the parentheses that we introduce to scope the -attributes. Take for example the type of x0 from above. It should be written -as: -

-        int A2 (A1 )[]
-
-But this will lead most C parsers into deep confusion because the parentheses -around A1 will be confused for parentheses of a function designator. To push -this problem around (I don't know a solution) whenever we are about to print a -parenthesized declarator with no name but with attributes, we comment out the -attributes so you can see them (for whatever is worth) without confusing the -compiler. For example, here is how we would print the above type: -

-        int A2 /*(A1 )*/[]
-
- - -
Handling of predefined GCC attributes
- -GCC already supports attributes in a lot of places in declarations. The only -place where we support attributes and GCC does not is right before the { that -starts a function body.
-
-GCC classifies its attributes in attributes for functions, for variables and -for types, although the latter category is only usable in definition of struct -or union types and is not nearly as powerful as the CIL type attributes. We -have made an effort to reclassify GCC attributes as name and type attributes -(they only apply for function types). Here is what we came up with: -
  • - GCC name attributes:
    -
    -section, constructor, destructor, unused, weak, no_instrument_function, - noreturn, alias, no_check_memory_usage, dllinport, dllexport, exception, - model
    -
    -Note: the "noreturn" attribute would be more appropriately qualified as a - function type attribute. But we classify it as a name attribute to make - it easier to support a similarly named MSVC attribute.
    -
    -
  • GCC function type attributes:
    -
    -fconst (printed as "const"), format, regparm, stdcall, - cdecl, longcall
    -
    -I was not able to completely decipher the position in which these attributes - must go. So, the CIL elaborator knows these names and applies the following - rules: -
    • - All of the name attributes that appear in the specifier part (i.e. at - the beginning) of a declaration are associated with all declared names.
      -
      -
    • All of the name attributes that appear at the end of a declarator are - associated with the particular name being declared.
      -
      -
    • More complicated is the handling of the function type attributes, since - there can be more than one function in a single declaration (a function - returning a pointer to a function). Lacking any real understanding of how - GCC handles this, I attach the function type attribute to the "nearest" - function. This means that if a pointer to a function is "nearby" the - attribute will be correctly associated with the function. In truth I pray - that nobody uses declarations as that of x3 above. -
    -
- - -
Handling of predefined MSVC attributes
- -MSVC has two kinds of attributes, declaration modifiers to be printed before - the storage specifier using the notation "__declspec(...)" and a few - function type attributes, printed almost as our CIL function type - attributes.
-
-The following are the name attributes that are printed using - __declspec right before the storage designator of the declaration: - thread, naked, dllimport, dllexport, noreturn
-
-The following are the function type attributes supported by MSVC: - fastcall, cdecl, stdcall
-
-It is not worth going into the obscure details of where MSVC accepts these - type attributes. The parser thinks it knows these details and it pulls - these attributes from wherever they might be placed. The important thing - is that MSVC will accept if we print them according to the rules of the CIL - attributes !
-
- - -

7  The CIL Driver

- -We have packaged CIL as an application cilly that contains certain -example modules, such as logwrites.ml (a module -that instruments code to print the addresses of memory locations being -written). Normally, you write another module like that, add command-line -options and an invocation of your module in src/main.ml. Once you compile -CIL you will obtain the file obj/cilly.asm.exe.
-
-We wrote a driver for this executable that makes it easy to invoke your -analysis on existing C code with very little manual intervention. This driver -is bin/cilly and is quite powerful. Note that the cilly script -is configured during installation with the path where CIL resides. This means -that you can move it to any place you want.
-
-A simple use of the driver is: -
-bin/cilly --save-temps -D HAPPY_MOOD -I myincludes hello.c -o hello
-
---save-temps tells CIL to save the resulting output files in the -current directory. Otherwise, they'll be put in /tmp and deleted -automatically. Not that this is the only CIL-specific flag in the -list – the other flags use gcc's syntax.
-
-This performs the following actions: -
  • -preprocessing using the -D and -I arguments with the resulting - file left in hello.i, -
  • the invocation of the cilly.asm application which parses hello.i - converts it to CIL and the pretty-prints it to hello.cil.c -
  • another round of preprocessing with the result placed in hello.cil.i -
  • the true compilation with the result in hello.cil.o -
  • a linking phase with the result in hello -
-Note that cilly behaves like the gcc compiler. This makes it -easy to use it with existing Makefiles: -
-make CC="bin/cilly" LD="bin/cilly"
-
- cilly can also behave as the Microsoft Visual C compiler, if the first - argument is --mode=MSVC: -
-bin/cilly --mode=MSVC /D HAPPY_MOOD /I myincludes hello.c /Fe hello.exe
-
- (This in turn will pass a --MSVC flag to the underlying cilly.asm - process which will make it understand the Microsoft Visual C extensions)
-
-cilly can also behave as the archiver ar, if it is passed an -argument --mode=AR. Note that only the cr mode is supported (create a -new archive and replace all files in there). Therefore the previous version of -the archive is lost.
-
-Furthermore, cilly allows you to pass some arguments on to the -underlying cilly.asm process. As a general rule all arguments that start -with -- and that cilly itself does not process, are passed on. For -example, -
-bin/cilly --dologwrites -D HAPPY_MOOD -I myincludes hello.c -o hello.exe
-
- will produce a file hello.cil.c that prints all the memory addresses -written by the application.
-
-The most powerful feature of cilly is that it can collect all the -sources in your project, merge them into one file and then apply CIL. This -makes it a breeze to do whole-program analysis and transformation. All you -have to do is to pass the --merge flag to cilly: -
-make CC="bin/cilly --save-temps --dologwrites --merge"
-
- You can even leave some files untouched: -
-make CC="bin/cilly --save-temps --dologwrites --merge --leavealone=foo --leavealone=bar"
-
- This will merge all the files except those with the basename foo and -bar. Those files will be compiled as usual and then linked in at the very -end.
-
-The sequence of actions performed by cilly depends on whether merging -is turned on or not: -
  • -If merging is off -
    1. - For every file file.c to compile -
      1. - Preprocess the file with the given arguments to - produce file.i -
      2. Invoke cilly.asm to produce a file.cil.c -
      3. Preprocess to file.cil.i -
      4. Invoke the underlying compiler to produce file.cil.o -
      -
    2. Link the resulting objects -
    -
  • If merging is on -
    1. - For every file file.c to compile -
      1. - Preprocess the file with the given arguments to - produce file.i -
      2. Save the preprocessed source as file.o -
      -
    2. When linking executable hello.exe, look at every object - file that must be linked and see if it actually - contains preprocessed source. Pass all those files to a - special merging application (described in - Section 13) to produce hello.exe_comb.c -
    3. Invoke cilly.asm to produce a hello.exe_comb.cil.c -
    4. Preprocess to hello.exe_comb.cil.i -
    5. Invoke the underlying compiler to produce hello.exe_comb.cil.o -
    6. Invoke the actual linker to produce hello.exe -
    -
-Note that files that you specify with --leavealone are not merged and -never presented to CIL. They are compiled as usual and then are linked in at -the end.
-
-And a final feature of cilly is that it can substitute copies of the -system's include files: -
-make CC="bin/cilly --includedir=myinclude"
-
- This will force the preprocessor to use the file myinclude/xxx/stdio.h -(if it exists) whenever it encounters #include <stdio.h>. The xxx is -a string that identifies the compiler version you are using. This modified -include files should be produced with the patcher script (see -Section 14).
-
- - -

7.1  cilly Options

- -Among the options for the cilly you can put anything that can normally -go in the command line of the compiler that cilly is impersonating. -cilly will do its best to pass those options along to the appropriate -subprocess. In addition, the following options are supported (a complete and -up-to-date list can always be obtained by running cilly --help): -
  • ---mode=mode This must be the first argument if present. It makes -cilly behave as a given compiled. The following modes are recognized: -
    • - GNUCC - the GNU C Compiler. This is the default. -
    • MSVC - the Microsoft Visual C compiler. Of course, you should - pass only MSVC valid options in this case. -
    • AR - the archiver ar. Only the mode cr is supported and - the original version of the archive is lost. -
    -
  • --help Prints a list of the options supported. -
  • --verbose Prints lots of messages about what is going on. -
  • --stages Less than --verbose but lets you see what cilly - is doing. -
  • --merge This tells cilly to first attempt to collect into one -source file all of the sources that make your application, and then to apply -cilly.asm on the resulting source. The sequence of actions in this case is -described above and the merger itself is described in Section 13.
    -
    -
  • --leavealone=xxx. Do not merge and do not present to CIL the files -whose basename is "xxx". These files are compiled as usual and linked in at -the end. -
  • --includedir=xxx. Override the include files with those in the given -directory. The given directory is the same name that was given an an argument -to the patcher (see Section 14). In particular this means that -that directory contains subdirectories named based on the current compiler -version. The patcher creates those directories. -
  • --usecabs. Do not CIL, but instead just parse the source and print -its AST out. This should looked like the preprocessed file. This is useful -when you suspect that the conversion to CIL phase changes the meaning of the -program. -
  • --save-temps=xxx. Temporary files are preserved in the xxx - directory. For example, the output of CIL will be put in a file - named *.cil.c. -
  • --save-temps. Temporay files are preserved in the current directory. -
- - -

7.2  cilly.asm Options

- - -All of the options that start with -- and are not understood by -cilly are passed on to cilly.asm. cilly also passes along to -cilly.asm flags such as --MSVC that both need to know -about. The following options are supported:
-
-       General Options: -
  • - --version output version information and exit -
  • --verbose Print lots of random stuff. This is passed on from cilly -
  • --warnall Show all warnings. -
  • --debug=xxx turns on debugging flag xxx -
  • --nodebug=xxx turns off debugging flag xxx -
  • --flush Flush the output streams often (aids debugging). -
  • --check Run a consistency check over the CIL after every operation. -
  • --nocheck turns off consistency checking of CIL. -
  • --noPrintLn Don't output #line directives in the output. -
  • --commPrintLn Print #line directives in the output, but - put them in comments. -
  • --log=xxx Set the name of the log file. By default stderr is used -
  • --MSVC Enable MSVC compatibility. Default is GNU. -
  • --ignore-merge-conflicts ignore merging conflicts. -
  • --extrafiles=filename: the name of a file that contains - a list of additional files to process, separated by whitespace. -
  • --stats Print statistics about the running time of the - parser, conversion to CIL, etc. Also prints memory-usage - statistics. You can time parts of your own code as well. Calling - (Stats.time “label” func arg) will evaluate (func arg) - and remember how long this takes. If you call Stats.time - repeatedly with the same label, CIL will report the aggregate - time.
    -
    -If available, CIL uses the x86 performance counters for these - stats. This is very precise, but results in “wall-clock time.” - To report only user-mode time, find the call to Stats.reset in - main.ml, and change it to Stats.reset false.
    -
    -Lowering Options -
  • --noLowerConstants do not lower constant expressions. -
  • --noInsertImplicitCasts do not insert implicit casts. -
  • --forceRLArgEval Forces right to left evaluation of function arguments. -
  • --disallowDuplication Prevent small chunks of code from being duplicated. -
  • --keepunused Do not remove the unused variables and types. -
  • --rmUnusedInlines Delete any unused inline functions. This is the default in MSVC mode.
    -
    -Output Options: -
  • --printCilAsIs Do not try to simplify the CIL when - printing. Without this flag, CIL will attempt to produce prettier - output by e.g. changing while(1) into more meaningful loops. -
  • --noWrap do not wrap long lines when printing -
  • --out=xxx the name of the output CIL file. cilly - sets this for you. -
  • --mergedout=xxx specify the name of the merged file -
  • --cabsonly=xxx CABS output file name -
    -
    - Selected features. See Section 8 for more information. -
  • --dologcalls. Insert code in the processed source to print the name of -functions as are called. Implemented in src/ext/logcalls.ml. -
  • --dologwrites. Insert code in the processed source to print the -address of all memory writes. Implemented in src/ext/logwrites.ml. -
  • --dooneRet. Make each function have at most one 'return'. -Implemented in src/ext/oneret.ml. -
  • --dostackGuard. Instrument function calls and returns to -maintain a separate stack for return addresses. Implemeted in -src/ext/heapify.ml. -
  • --domakeCFG. Make the program look more like a CFG. Implemented -in src/cil.ml. -
  • --dopartial. Do interprocedural partial evaluation and -constant folding. Implemented in src/ext/partial.ml. -
  • --dosimpleMem. Simplify all memory expressions. Implemented in -src/ext/simplemem.ml.
    -
    -For an up-to-date list of available options, run cilly.asm --help.
- - -

8  Library of CIL Modules

- -
-
-We are developing a suite of modules that use CIL for program analyses and -transformations that we have found useful. You can use these modules directly -on your code, or generally as inspiration for writing similar modules. A -particularly big and complex application written on top of CIL is CCured -(../ccured/index.html).
-
- - -

8.1  Control-Flow Graphs

- -The Cil.stmt datatype includes fields for intraprocedural -control-flow information: the predecessor and successor statements of -the current statement. This information is not computed by default. -If you want to use the control-flow graph, or any of the extensions in -this section that require it, you have to explicitly ask CIL to -compute the CFG.
-
- - -

8.1.1  The CFG module (new in CIL 1.3.5)

- -The best way to compute the CFG is with the CFG module. Just invoke -Cfg.computeFileCFG on your file. The Cfg API -describes the rest of actions you can take with this module, including -computing the CFG for one function at a time, or printing the CFG in -dot form.
-
- - -

8.1.2  Simplified control flow

- -CIL can reduce high-level C control-flow constructs like switch and -continue to lower-level gotos. This completely eliminates some -possible classes of statements from the program and may make the result -easier to analyze (e.g., it simplifies data-flow analysis).
-
-You can invoke this transformation on the command line with ---domakeCFG or programatically with Cil.prepareCFG. -After calling Cil.prepareCFG, you can use Cil.computeCFGInfo -to compute the CFG information and find the successor and predecessor -of each statement.
-
-For a concrete example, you can see how cilly --domakeCFG -transforms the following code (note the fall-through in case 1): -

-  int foo (int predicate) {
-    int x = 0;
-    switch (predicate) {
-      case 0: return 111;
-      case 1: x = x + 1;
-      case 2: return (x+3);
-      case 3: break;
-      default: return 222;
-    }
-    return 333;
-  }
-
-See the CIL output for this -code fragment
-
- - -

8.2  Data flow analysis framework

- -The Dataflow module (click for the ocamldoc) contains a -parameterized framework for forward and backward data flow -analyses. You provide the transfer functions and this module does the -analysis. You must compute control-flow information (Section 8.1) -before invoking the Dataflow module.
-
- - -

8.3  Dominators

- -The module Dominators contains the computation of immediate - dominators. It uses the Dataflow module.
-
- - -

8.4  Points-to Analysis

- -The module ptranal.ml contains two interprocedural points-to -analyses for CIL: Olf and Golf. Olf is the default. -(Switching from olf.ml to golf.ml requires a change in -Ptranal and a recompiling cilly.)
-
-The analyses have the following characteristics: -
  • -Not based on C types (inferred pointer relationships are sound - despite most kinds of C casts) -
  • One level of subtyping -
  • One level of context sensitivity (Golf only) -
  • Monomorphic type structures -
  • Field insensitive (fields of structs are conflated) -
  • Demand-driven (points-to queries are solved on demand) -
  • Handle function pointers -
-The analysis itself is factored into two components: Ptranal, -which walks over the CIL file and generates constraints, and Olf -or Golf, which solve the constraints. The analysis is invoked -with the function Ptranal.analyze_file: Cil.file -> - unit. This function builds the points-to graph for the CIL file -and stores it internally. There is currently no facility for clearing -internal state, so Ptranal.analyze_file should only be called -once.
-
-The constructed points-to graph supports several kinds of queries, -including alias queries (may two expressions be aliased?) and -points-to queries (to what set of locations may an expression point?).
-
-The main interface with the alias analysis is as follows: -
  • -Ptranal.may_alias: Cil.exp -> Cil.exp -> bool. If - true, the two expressions may have the same value. -
  • Ptranal.resolve_lval: Cil.lval -> (Cil.varinfo - list). Returns the list of variables to which the given - left-hand value may point. -
  • Ptranal.resolve_exp: Cil.exp -> (Cil.varinfo list). - Returns the list of variables to which the given expression may - point. -
  • Ptranal.resolve_funptr: Cil.exp -> (Cil.fundec - list). Returns the list of functions to which the given - expression may point. -
-The precision of the analysis can be customized by changing the values -of several flags: -
  • -Ptranal.no_sub: bool ref. - If true, subtyping is disabled. Associated commandline option: - --ptr_unify. -
  • Ptranal.analyze_mono: bool ref. - (Golf only) If true, context sensitivity is disabled and the - analysis is effectively monomorphic. Commandline option: - --ptr_mono. -
  • Ptranal.smart_aliases: bool ref. - (Golf only) If true, “smart” disambiguation of aliases is - enabled. Otherwise, aliases are computed by intersecting points-to - sets. This is an experimental feature. -
  • Ptranal.model_strings: bool ref. - Make the alias analysis model string constants by treating them as - pointers to chars. Commandline option: --ptr_model_strings -
  • Ptranal.conservative_undefineds: bool ref. - Make the most pessimistic assumptions about globals if an undefined - function is present. Such a function can write to every global - variable. Commandline option: --ptr_conservative -
-In practice, the best precision/efficiency tradeoff is achieved by -setting Ptranal.no_sub to false, Ptranal.analyze_mono to -true, and Ptranal.smart_aliases to false. These are the -default values of the flags.
-
-There are also a few flags that can be used to inspect or serialize -the results of the analysis. -
  • -Ptranal.debug_may_aliases. - Print the may-alias relationship of each pair of expressions in the - program. Commandline option: --ptr_may_aliases. -
  • Ptranal.print_constraints: bool ref. - If true, the analysis will print each constraint as it is - generated. -
  • Ptranal.print_types: bool ref. - If true, the analysis will print the inferred type of each - variable in the program.
    -
    -If Ptranal.analyze_mono and Ptranal.no_sub are both - true, this output is sufficient to reconstruct the points-to - graph. One nice feature is that there is a pretty printer for - recursive types, so the print routine does not loop. -
  • Ptranal.compute_results: bool ref. - If true, the analysis will print out the points-to set of each - variable in the program. This will essentially serialize the - points-to graph. -
- - -

8.5  StackGuard

- -The module heapify.ml contains a transformation similar to the one -described in “StackGuard: Automatic Adaptive Detection and Prevention of -Buffer-Overflow Attacks”, Proceedings of the 7th USENIX Security -Conference. In essence it modifies the program to maintain a separate -stack for return addresses. Even if a buffer overrun attack occurs the -actual correct return address will be taken from the special stack.
-
-Although it does work, this CIL module is provided mainly as an example of -how to perform a simple source-to-source program analysis and -transformation. As an optimization only functions that contain a dangerous -local array make use of the special return address stack.
-
-For a concrete example, you can see how cilly --dostackGuard -transforms the following dangerous code: -

-  int dangerous() {
-    char array[10];
-    scanf("%s",array); // possible buffer overrun!
-  }
-
-  int main () {
-    return dangerous();
-  }
-
-See the CIL output for this -code fragment
-
- - -

8.6  Heapify

- -The module heapify.ml also contains a transformation that moves all -dangerous local arrays to the heap. This also prevents a number of buffer -overruns.
-
-For a concrete example, you can see how cilly --doheapify -transforms the following dangerous code: -

-  int dangerous() {
-    char array[10];
-    scanf("%s",array); // possible buffer overrun!
-  }
-
-  int main () {
-    return dangerous();
-  }
-
-See the CIL output for this -code fragment
-
- - -

8.7  One Return

- -The module oneret.ml contains a transformation the ensures that all -function bodies have at most one return statement. This simplifies a number -of analyses by providing a canonical exit-point.
-
-For a concrete example, you can see how cilly --dooneRet -transforms the following code: -

-  int foo (int predicate) {
-    if (predicate <= 0) {
-      return 1;
-    } else {
-      if (predicate > 5)
-        return 2;
-      return 3;
-    }
-  }
-
-See the CIL output for this -code fragment
-
- - -

8.8  Partial Evaluation and Constant Folding

- -The partial.ml module provides a simple interprocedural partial -evaluation and constant folding data-flow analysis and transformation. This -transformation requires the --domakeCFG option.
-
-For a concrete example, you can see how cilly --domakeCFG --dopartial -transforms the following code (note the eliminated if branch and the -partial optimization of foo): -

-  int foo(int x, int y) {
-    int unknown;
-    if (unknown)
-      return y+2;     
-    return x+3;      
-  }
-
-  int main () {
-    int a,b,c;
-    a = foo(5,7) + foo(6,7);
-    b = 4;
-    c = b * b;      
-    if (b > c)     
-      return b-c;
-    else
-      return b+c; 
-  }
-
-See the CIL output for this -code fragment
-
- - -

8.9  Reaching Definitions

- -The reachingdefs.ml module uses the dataflow framework and CFG -information to calculate the definitions that reach each -statement. After computing the CFG (Section 8.1) and calling -computeRDs on a -function declaration, ReachingDef.stmtStartData will contain a -mapping from statement IDs to data about which definitions reach each -statement. In particular, it is a mapping from statement IDs to a -triple the first two members of which are used internally. The third -member is a mapping from variable IDs to Sets of integer options. If -the set contains Some(i), then the definition of that variable -with ID i reaches that statement. If the set contains None, -then there is a path to that statement on which there is no definition -of that variable. Also, if the variable ID is unmapped at a -statement, then no definition of that variable reaches that statement.
-
-To summarize, reachingdefs.ml has the following interface: -
  • -computeRDs – Computes reaching definitions. Requires that -CFG information has already been computed for each statement. -
  • ReachingDef.stmtStartData – contains reaching -definition data after computeRDs is called. -
  • ReachingDef.defIdStmtHash – Contains a mapping -from definition IDs to the ID of the statement in which -the definition occurs. -
  • getRDs – Takes a statement ID and returns -reaching definition data for that statement. -
  • instrRDs – Takes a list of instructions and the -definitions that reach the first instruction, and for -each instruction calculates the definitions that reach -either into or out of that instruction. -
  • rdVisitorClass – A subclass of nopCilVisitor that -can be extended such that the current reaching definition -data is available when expressions are visited through -the get_cur_iosh method of the class. -
- - -

8.10  Available Expressions

- -The availexps.ml module uses the dataflow framework and CFG -information to calculate something similar to a traditional available -expressions analysis. After computeAEs is called following a CFG -calculation (Section 8.1), AvailableExps.stmtStartData will -contain a mapping -from statement IDs to data about what expressions are available at -that statement. The data for each statement is a mapping for each -variable ID to the whole expression available at that point(in the -traditional sense) which the variable was last defined to be. So, -this differs from a traditional available expressions analysis in that -only whole expressions from a variable definition are considered rather -than all expressions.
-
-The interface is as follows: -
  • -computeAEs – Computes available expressions. Requires -that CFG information has already been comptued for each statement. -
  • AvailableExps.stmtStartData – Contains available -expressions data for each statement after computeAEs has been -called. -
  • getAEs – Takes a statement ID and returns -available expression data for that statement. -
  • instrAEs – Takes a list of instructions and -the availalbe expressions at the first instruction, and -for each instruction calculates the expressions available -on entering or exiting each instruction. -
  • aeVisitorClass – A subclass of nopCilVisitor that -can be extended such that the current available expressions -data is available when expressions are visited through the -get_cur_eh method of the class. -
- - -

8.11  Liveness Analysis

- -The liveness.ml module uses the dataflow framework and -CFG information to calculate which variables are live at -each program point. After computeLiveness is called -following a CFG calculation (Section 8.1), LiveFlow.stmtStartData will -contain a mapping for each statement ID to a set of varinfos -for varialbes live at that program point.
-
-The interface is as follows: -
  • -computeLiveness – Computes live variables. Requires -that CFG information has already been computed for each statement. -
  • LiveFlow.stmtStartData – Contains live variable data -for each statement after computeLiveness has been called. -
-Also included in this module is a command line interface that -will cause liveness data to be printed to standard out for -a particular function or label. -
  • -–doliveness – Instructs cilly to comptue liveness -information and to print on standard out the variables live -at the points specified by –live_func and live_label. -If both are ommitted, then nothing is printed. -
  • –live_func – The name of the function whose -liveness data is of interest. If –live_label is ommitted, -then data for each statement is printed. -
  • –live_label – The name of the label at which -the liveness data will be printed. -
- - -

8.12  Dead Code Elimination

- -The module deadcodeelim.ml uses the reaching definitions -analysis to eliminate assignment instructions whose results -are not used. The interface is as follows: -
  • -elim_dead_code – Performs dead code elimination -on a function. Requires that CFG information has already -been computed (Section 8.1). -
  • dce – Performs dead code elimination on an -entire file. Requires that CFG information has already -been computed. -
- - -

8.13  Simple Memory Operations

- -The simplemem.ml module allows CIL lvalues that contain memory -accesses to be even futher simplified via the introduction of -well-typed temporaries. After this transformation all lvalues involve -at most one memory reference.
-
-For a concrete example, you can see how cilly --dosimpleMem -transforms the following code: -

-  int main () {
-    int ***three;
-    int **two;
-    ***three = **two; 
-  } 
-
-See the CIL output for this -code fragment
-
- - -

8.14  Simple Three-Address Code

- -The simplify.ml module further reduces the complexity of program -expressions and gives you a form of three-address code. After this -transformation all expressions will adhere to the following grammar: -
- basic::=
-    Const _ 
-    Addrof(Var v, NoOffset)
-    StartOf(Var v, NoOffset)
-    Lval(Var v, off), where v is a variable whose address is not taken
-                      and off contains only "basic"
-
- exp::=
-    basic
-    Lval(Mem basic, NoOffset)
-    BinOp(bop, basic, basic)
-    UnOp(uop, basic)
-    CastE(t, basic)
-   
- lval ::= 
-    Mem basic, NoOffset
-    Var v, off, where v is a variable whose address is not taken and off
-                contains only "basic"
-
In addition, all sizeof and alignof forms are turned into -constants. Accesses to arrays and variables whose address is taken are -turned into "Mem" accesses. All field and index computations are turned -into address arithmetic.
-
-For a concrete example, you can see how cilly --dosimplify -transforms the following code: -

-  int main() {
-    struct mystruct {
-      int a;
-      int b;
-    } m;
-    int local;
-    int arr[3];
-    int *ptr;
-
-    ptr = &local;
-    m.a = local + sizeof(m) + arr[2];
-    return m.a; 
-  } 
-
-See the CIL output for this -code fragment
-
- - -

8.15  Converting C to C++

- -The module canonicalize.ml performs several transformations to correct -differences between C and C++, so that the output is (hopefully) valid -C++ code. This may be incomplete — certain fixes which are necessary -for some programs are not yet implemented.
-
-Using the --doCanonicalize option with CIL will perform the -following changes to your program: -
  1. -Any variables that use C++ keywords as identifiers are renamed. -
  2. C allows global variables to have multiple declarations and - multiple (equivalent) definitions. This transformation removes - all but one declaration and all but one definition. -
  3. __inline is #defined to inline, and __restrict - is #defined to nothing. -
  4. C allows function pointers with no specified arguments to be used on - any argument list. To make C++ accept this code, we insert a cast - from the function pointer to a type that matches the arguments. Of - course, this does nothing to guarantee that the pointer actually has - that type. -
  5. Makes casts from int to enum types explicit. (CIL changes enum - constants to int constants, but doesn't use a cast.) -
- - -

9  Controlling CIL

- -In the process of converting a C file to CIL we drop the unused prototypes -and even inline function definitions. This results in much smaller files. If -you do not want this behavior then you must pass the --keepunused argument -to the CIL application.
-
-Alternatively you can put the following pragma in the code (instructing CIL -to specifically keep the declarations and definitions of the function -func1 and variable var2, the definition of type foo and of -structure bar): -

-#pragma cilnoremove("func1", "var2", "type foo", "struct bar")
-
- - -

10  GCC Extensions

- -The CIL parser handles most of the gcc -extensions -and compiles them to CIL. The following extensions are not handled (note that -we are able to compile a large number of programs, including the Linux kernel, -without encountering these): -
  1. -Nested function definitions. -
  2. Constructing function calls. -
  3. Naming an expression's type. -
  4. Complex numbers -
  5. Hex floats -
  6. Subscripts on non-lvalue arrays. -
  7. Forward function parameter declarations -
-The following extensions are handled, typically by compiling them away: -
  1. -Attributes for functions, variables and types. In fact, we have a clear -specification (see Section 6.4) of how attributes are interpreted. The -specification extends that of gcc. -
  2. Old-style function definitions and prototypes. These are translated to -new-style. -
  3. Locally-declared labels. As part of the translation to CIL, we generate -new labels as needed. -
  4. Labels as values and computed goto. This allows a program to take the -address of a label and to manipulate it as any value and also to perform a -computed goto. We compile this by assigning each label whose address is taken -a small integer that acts as its address. Every computed goto in the body -of the function is replaced with a switch statement. If you want to invoke -the label from another function, you are on your own (the gcc -documentation says the same.) -
  5. Generalized lvalues. You can write code like (a, b) += 5 and it gets -translated to CIL. -
  6. Conditionals with omitted operands. Things like x ? : y are -translated to CIL. -
  7. Double word integers. The type long long and the LL suffix on -constants is understood. This is currently interpreted as 64-bit integers. -
  8. Local arrays of variable length. These are converted to uses of -alloca, the array variable is replaced with a pointer to the allocated -array and the instances of sizeof(a) are adjusted to return the size of -the array and not the size of the pointer. -
  9. Non-constant local initializers. Like all local initializers these are -compiled into assignments. -
  10. Compound literals. These are also turned into assignments. -
  11. Designated initializers. The CIL parser actually supports the full ISO -syntax for initializers, which is more than both gcc and MSVC. I -(George) think that this is the most complicated part of the C language and -whoever designed it should be banned from ever designing languages again. -
  12. Case ranges. These are compiled into separate cases. There is no code -duplication, just a larger number of case statements. -
  13. Transparent unions. This is a strange feature that allows you to define -a function whose formal argument has a (tranparent) union type, but the -argument is called as if it were the first element of the union. This is -compiled away by saying that the type of the formal argument is that of the -first field, and the first thing in the function body we copy the formal into -a union.
    -
    -
  14. Inline assembly-language. The full syntax is supported and it is carried -as such in CIL.
    -
    -
  15. Function names as strings. The identifiers __FUNCTION__ and -__PRETTY_FUNCTION__ are replaced with string literals.
    -
    -
  16. Keywords typeof, alignof, inline are supported. -
- - -

11  CIL Limitations

- -There are several implementation details of CIL that might make it unusable - or less than ideal for certain tasks: -
  • -CIL operates after preprocessing. If you need to see comments, for -example, you cannot use CIL. But you can use attributes and pragmas instead. -And there is some support to help you patch the include files before they are -seen by the preprocessor. For example, this is how we turn some -#defines that we don't like into function calls.
    -
    -
  • CIL does transform the code in a non-trivial way. This is done in order -to make most analyses easier. But if you want to see the code e1, e2++ -exactly as it appears in the code, then you should not use CIL.
    -
    -
  • CIL removes all local scopes and moves all variables to function -scope. It also separates a declaration with an initializer into a declaration -plus an assignment. The unfortunate effect of this transformation is that -local variables cannot have the const qualifier.
- - -

12  Known Bugs and Limitations

- -
  • In the new versions of glibc there is a function - __builtin_va_arg that takes a type as its second argument. CIL - handles that through a slight trick. As it parses the function it changes a - call like: -
    -  mytype x = __builtin_va_arg(marker, mytype)
-
    into -
    - mytype x;
- __builtin_va_arg(marker, sizeof(mytype), &x);
-
    - The latter form is used internally in CIL. However, the CIL pretty printer - will try to emit the original code.
    -
    -Similarly, __builtin_types_compatible_p(t1, t2), which takes - types as arguments, is represented internally as - __builtin_types_compatible_p(sizeof t1, sizeof t2), but the - sizeofs are removed when printing.
    -
    -
  • The implementation of bitsSizeOf does not take into account the -packing pragmas. However it was tested to be accurate on cygwin/gcc-2.95.3, -Linux/gcc-2.95.3 and on Windows/MSVC.
    -
    -
  • We do not support tri-graph sequences (ISO 5.2.1.1).
    -
    -
  • GCC has a strange feature called “extern inline”. Such a function can -be defined twice: first with the “extern inline” specifier and the second -time without it. If optimizations are turned off then the “extern inline” -definition is considered a prototype (its body is ignored). If optimizations -are turned on then the extern inline function is inlined at all of its -occurrences from the point of its definition all the way to the point where the -(optional) second definition appears. No body is generated for an extern -inline function. A body is generated for the real definition and that one is -used in the rest of the file.
    -
    -CIL will rename your extern inline function (and its uses) with the suffix - __extinline. This means that if you have two such definition, that do - different things and the optimizations are not on, then the CIL version might - compute a different answer !
    -
    -Also, if you have multiple extern inline declarations then CIL will ignore -but the first one. This is not so bad because GCC itself would not like it.
    -
    -
  • There are still a number of bugs in handling some obscure features of -GCC. For example, when you use variable-length arrays, CIL turns them into -calls to alloca. This means that they are deallocated when the function -returns and not when the local scope ends.
    -
    -Variable-length arrays are not supported as fields of a struct or union.
    -
    -
  • CIL cannot parse arbitrary #pragma directives. Their - syntax must follow gcc's attribute syntax to be understood. If you - need a pragma that does not follow gcc syntax, add that pragma's name - to no_parse_pragma in src/frontc/clexer.mll to indicate that - CIL should treat that pragma as a monolithic string rather than try - to parse its arguments.
    -
    -CIL cannot parse a line containing an empty #pragma.
    -
    -
  • CIL only parses #pragma directives at the "top level", this is, - outside of any enum, structure, union, or function definitions.
    -
    -If your compiler uses pragmas in places other than the top-level, - you may have to preprocess the sources in a special way (sed, perl, - etc.) to remove pragmas from these locations.
    -
    -
  • CIL cannot parse the following code (fixing this problem would require -extensive hacking of the LALR grammar): -
    
-int bar(int ()); // This prototype cannot be parsed
-int bar(int x()); // If you add a name to the function, it works
-int bar(int (*)()); // This also works (and it is more appropriate)
-

    -
    -
  • CIL also cannot parse certain K&R old-style prototypes with missing -return type: -
    
-g(); // This cannot be parsed
-int g(); // This is Ok
-

    -
    -
  • CIL does not understand some obscure combinations of type specifiers -(“signed” and “unsigned” applied to typedefs that themselves contain a -sign specification; you could argue that this should not be allowed anyway): -
    
-typedef signed char __s8;
-__s8 unsigned uchartest; // This is unsigned char for gcc
-

    -
    -
  • The statement x = 3 + x ++ will perform the increment of x - before the assignment, while gcc delays the increment after the - assignment. It turned out that this behavior is much easier to implement - than gcc's one, and either way is correct (since the behavior is unspecified - in this case). Similarly, if you write x = x ++; then CIL will perform - the increment before the assignment, whereas GCC and MSVC will perform it - after the assignment. -
- - -

13  Using the merger

- -
-
-There are many program analyses that are more effective when -done on the whole program.
-
-The merger is a tool that combines all of the C source files in a project -into a single C file. There are two tasks that a merger must perform: -
  1. -Detect what are all the sources that make a project and with what -compiler arguments they are compiled.
    -
    -
  2. Merge all of the source files into a single file. -
-For the first task the merger impersonates a compiler and a linker (both a -GCC and a Microsoft Visual C mode are supported) and it expects to be invoked -(from a build script or a Makefile) on all sources of the project. When -invoked to compile a source the merger just preprocesses the source and saves -the result using the name of the requested object file. By preprocessing at -this time the merger is able to take into account variations in the command -line arguments that affect preprocessing of different source files.
-
-When the merger is invoked to link a number of object files it collects the -preprocessed sources that were stored with the names of the object files, and -invokes the merger proper. Note that arguments that affect the compilation or -linking must be the same for all source files.
-
-For the second task, the merger essentially concatenates the preprocessed -sources with care to rename conflicting file-local declarations (we call this -process alpha-conversion of a file). The merger also attempts to remove -duplicate global declarations and definitions. Specifically the following -actions are taken: -
  • -File-scope names (static globals, names of types defined with -typedef, and structure/union/enumeration tags) are given new names if they -conflict with declarations from previously processed sources. The new name is -formed by appending the suffix ___n, where n is a unique integer -identifier. Then the new names are applied to their occurrences in the file.
    -
    -
  • Non-static declarations and definitions of globals are never renamed. -But we try to remove duplicate ones. Equality of globals is detected by -comparing the printed form of the global (ignoring the line number directives) -after the body has been alpha-converted. This process is intended to remove -those declarations (e.g. function prototypes) that originate from the same -include file. Similarly, we try to eliminate duplicate definitions of -inline functions, since these occasionally appear in include files.
    -
    -
  • The types of all global declarations with the same name from all files -are compared for type isomorphism. During this process, the merger detects all -those isomorphisms between structures and type definitions that are required for the merged program to be legal. Such structure tags and -typenames are coalesced and given the same name.
    -
    -
  • Besides the structure tags and type names that are required to be -isomorphic, the merger also tries to coalesce definitions of structures and -types with the same name from different file. However, in this case the merger -will not give an error if such definitions are not isomorphic; it will just -use different names for them.
    -
    -
  • In rare situations, it can happen that a file-local global in -encountered first and it is not renamed, only to discover later when -processing another file that there is an external symbol with the same name. -In this case, a second pass is made over the merged file to rename the -file-local symbol. -
-Here is an example of using the merger:
-
-The contents of file1.c is: -

-struct foo; // Forward declaration
-extern struct foo *global;
-
-The contents of file2.c is: -

-struct bar {
- int x;
- struct bar *next;
-};
-extern struct bar *global;
-struct foo {
- int y;
-};
-extern struct foo another;
-void main() {
-}
-
-There are several ways in which one might create an executable from these -files: -
  • -
    -gcc file1.c file2.c -o a.out
-

    -
    -
  • -gcc -c file1.c -o file1.o
-gcc -c file2.c -o file2.o
-ld file1.o file2.o -o a.out
-

    -
    -
  • -gcc -c file1.c -o file1.o
-gcc -c file2.c -o file2.o
-ar r libfile2.a file2.o
-gcc file1.o libfile2.a -o a.out
-

    -
    -
  • -gcc -c file1.c -o file1.o
-gcc -c file2.c -o file2.o
-ar r libfile2.a file2.o
-gcc file1.o -lfile2 -o a.out
-
-In each of the cases above you must replace all occurrences of gcc and -ld with cilly --merge, and all occurrences of ar with cilly ---merge --mode=AR. It is very important that the --merge flag be used -throughout the build process. If you want to see the merged source file you -must also pass the --keepmerged flag to the linking phase.
-
-The result of merging file1.c and file2.c is: -

-// from file1.c
-struct foo; // Forward declaration
-extern struct foo *global;
-
-// from file2.c
-struct foo {
- int x;
- struct foo *next;
-};
-struct foo___1 {
- int y;
-};
-extern struct foo___1 another;
-
- - -

14  Using the patcher

- -
-
-Occasionally we have needed to modify slightly the standard include files. -So, we developed a simple mechanism that allows us to create modified copies -of the include files and use them instead of the standard ones. For this -purpose we specify a patch file and we run a program caller Patcher which -makes modified copies of include files and applies the patch.
-
-The patcher is invoked as follows: -
-bin/patcher [options]
-
-Options:
-  --help       Prints this help message
-  --verbose    Prints a lot of information about what is being done
-  --mode=xxx   What tool to emulate: 
-                GNUCC     - GNU CC
-                MSVC      - MS VC cl compiler
-
-  --dest=xxx   The destination directory. Will make one if it does not exist
-  --patch=xxx  Patch file (can be specified multiple times)
-  --ppargs=xxx An argument to be passed to the preprocessor (can be specified
-               multiple times)
-
-  --ufile=xxx  A user-include file to be patched (treated as \#include "xxx")
-  --sfile=xxx  A system-include file to be patched (treated as \#include <xxx>)
- 
-  --clean       Remove all files in the destination directory
-  --dumpversion Print the version name used for the current compiler
-
- All of the other arguments are passed to the preprocessor. You should pass
- enough arguments (e.g., include directories) so that the patcher can find the
- right include files to be patched.
-
- Based on the given mode and the current version of the compiler (which -the patcher can print when given the dumpversion argument) the patcher -will create a subdirectory of the dest directory (say /usr/home/necula/cil/include), such as: -
-/usr/home/necula/cil/include/gcc_2.95.3-5
-
- In that file the patcher will copy the modified versions of the include files -specified with the ufile and sfile options. Each of these options can -be specified multiple times.
-
-The patch file (specified with the patch option) has a format inspired by -the Unix patch tool. The file has the following grammar: -
-<<< flags
-patterns
-===
-replacement
->>>
-
- The flags are a comma separated, case-sensitive, sequence of keywords or -keyword = value. The following flags are supported: -
  • -file=foo.h - will only apply the patch on files whose name is - foo.h. -
  • optional - this means that it is Ok if the current patch does not -match any of the processed files. -
  • group=foo - will add this patch to the named group. If this is not -specified then a unique group is created to contain just the current patch. -When all files specified in the command line have been patched, an error -message is generated for all groups for whom no member patch was used. We use -this mechanism to receive notice when the patch triggers are out-dated with -respect to the new include files. -
  • system=sysname - will only consider this pattern on a given -operating system. The “sysname” is reported by the “$Ô” variable in -Perl, except that Windows is always considered to have sysname -“cygwin.” For Linux use “linux” (capitalization matters). -
  • ateof - In this case the patterns are ignored and the replacement -text is placed at the end of the patched file. Use the file flag if you -want to restrict the files in which this replacement is performed. -
  • atsof - The patterns are ignored and the replacement text is placed -at the start of the patched file. Uf the file flag to restrict the -application of this patch to a certain file. -
  • disabled - Use this flag if you want to disable the pattern. -
-The patterns can consist of several groups of lines separated by the ||| -marker. Each of these group of lines is a multi-line pattern that if found in -the file will be replaced with the text given at the end of the block.
-
-The matching is space-insensitive.
-
-All of the markers <<<, |||, === and >>> must appear at the -beginning of a line but they can be followed by arbitrary text (which is -ignored).
-
-The replacement text can contain the special keyword @__pattern__@, -which is substituted with the pattern that matched.
-
- - -

15  Debugging support

- -Most of the time we debug our code using the Errormsg module along with the -pretty printer. But if you want to use the Ocaml debugger here is an easy way -to do it. Say that you want to debug the invocation of cilly that arises out -of the following command: -
-cilly -c hello.c 
-
- You must follow the installation instructions -to install the Elist support files for ocaml and to extend your .emacs -appropriately. Then from within Emacs you do -
-ALT-X my-camldebug
-
- This will ask you for the command to use for running the Ocaml debugger -(initially the default will be “ocamldebug” or the last command you -introduced). You use the following command: -
-cilly --ocamldebug -c hello.c 
-
- This will run cilly as usual and invoke the Ocaml debugger when the cilly -engine starts. The advantage of this way of invoking the debugger is that the -directory search paths are set automatically and the right set or arguments is -passed to the debugger.
-
- - -

16  Who Says C is Simple?

- -When I (George) started to write CIL I thought it was going to take two weeks. -Exactly a year has passed since then and I am still fixing bugs in it. This -gross underestimate was due to the fact that I thought parsing and making -sense of C is simple. You probably think the same. What I did not expect was -how many dark corners this language has, especially if you want to parse -real-world programs such as those written for GCC or if you are more ambitious -and you want to parse the Linux or Windows NT sources (both of these were -written without any respect for the standard and with the expectation that -compilers will be changed to accommodate the program).
-
-The following examples were actually encountered either in real programs or -are taken from the ISO C99 standard or from the GCC's testcases. My first -reaction when I saw these was: Is this C?. The second one was : What the hell does it mean?.
-
-If you are contemplating doing program analysis for C on abstract-syntax -trees then your analysis ought to be able to handle these things. Or, you can -use CIL and let CIL translate them into clean C code.
-
- - -

16.1  Standard C

- -
  1. Why does the following code return 0 for most values of x? (This -should be easy.) -
    
-  int x;
-  return x == (1 && x);
-
    -See the CIL output for this -code fragment
    -
    -
  2. Why does the following code return 0 and not -1? (Answer: because -sizeof is unsigned, thus the result of the subtraction is unsigned, thus -the shift is logical.) -
    
- return ((1 - sizeof(int)) >> 32);
-
    -See the CIL output for this -code fragment
    -
    -
  3. Scoping rules can be tricky. This function returns 5. -
    
-int x = 5;
-int f() {
-  int x = 3;
-  {
-    extern int x;
-    return x;
-  }
-}
-
    -See the CIL output for this -code fragment
    -
    -
  4. Functions and function pointers are implicitly converted to each other. -
    
-int (*pf)(void);
-int f(void) {
-
-   pf = &f; // This looks ok
-   pf = ***f; // Dereference a function?
-   pf(); // Invoke a function pointer?     
-   (****pf)();  // Looks strange but Ok
-   (***************f)(); // Also Ok             
-}
-
    -See the CIL output for this -code fragment
    -
    -
  5. Initializer with designators are one of the hardest parts about ISO C. -Neither MSVC or GCC implement them fully. GCC comes close though. What is the -final value of i.nested.y and i.nested.z? (Answer: 2 and respectively -6). -
    
-struct { 
-   int x; 
-   struct { 
-       int y, z; 
-   } nested;
-} i = { .nested.y = 5, 6, .x = 1, 2 };               
-
    -See the CIL output for this -code fragment
    -
    -
  6. This is from c-torture. This function returns 1. -
    
-typedef struct
-{
-  char *key;
-  char *value;
-} T1;
-
-typedef struct
-{
-  long type;
-  char *value;
-} T3;
-
-T1 a[] =
-{
-  {
-    "",
-    ((char *)&((T3) {1, (char *) 1}))
-  }
-};
-int main() {
-   T3 *pt3 = (T3*)a[0].value;
-   return pt3->value;
-}
-
    -See the CIL output for this -code fragment
    -
    -
  7. Another one with constructed literals. This one is legal according to -the GCC documentation but somehow GCC chokes on (it works in CIL though). This -code returns 2. -
    
- return ((int []){1,2,3,4})[1];
-
    -See the CIL output for this -code fragment
    -
    -
  8. In the example below there is one copy of “bar” and two copies of - “pbar” (static prototypes at block scope have file scope, while for all - other types they have block scope). -
    
-  int foo() {
-     static bar();
-     static (*pbar)() = bar;
-
-  }
-
-  static bar() { 
-    return 1;
-  }
-
-  static (*pbar)() = 0;
-
    -See the CIL output for this -code fragment
    -
    -
  9. Two years after heavy use of CIL, by us and others, I discovered a bug - in the parser. The return value of the following function depends on what - precedence you give to casts and unary minus: -
    
-  unsigned long foo() {
-    return (unsigned long) - 1 / 8;
-  }
-
    -See the CIL output for this -code fragment
    -
    -The correct interpretation is ((unsigned long) - 1) / 8, which is a - relatively large number, as opposed to (unsigned long) (- 1 / 8), which - is 0.
- - -

16.2  GCC ugliness

- -
  1. GCC has generalized lvalues. You can take the address of a lot of -strange things: -
    
-  int x, y, z;
-  return &(x ? y : z) - & (x++, x);
-
    -See the CIL output for this -code fragment
    -
    -
  2. GCC lets you omit the second component of a conditional expression. -
    
-  extern int f();
-  return f() ? : -1; // Returns the result of f unless it is 0
-
    -See the CIL output for this -code fragment
    -
    -
  3. Computed jumps can be tricky. CIL compiles them away in a fairly clean -way but you are on your own if you try to jump into another function this way. -
    
-static void *jtab[2]; // A jump table
-static int doit(int x){
- 
-  static int jtab_init = 0;
-  if(!jtab_init) { // Initialize the jump table
-    jtab[0] = &&lbl1;
-    jtab[1] = &&lbl2;
-    jtab_init = 1;
-  }
-  goto *jtab[x]; // Jump through the table
-lbl1:
-  return 0;
-lbl2:
-  return 1;
-}
- 
-int main(void){
-  if (doit(0) != 0) exit(1);
-  if (doit(1) != 1) exit(1);
-  exit(0);
-}
-
    -See the CIL output for this -code fragment
    -
    -
  4. A cute little example that we made up. What is the returned value? -(Answer: 1); -
    
- return ({goto L; 0;}) && ({L: 5;});
-
    -See the CIL output for this -code fragment
    -
    -
  5. extern inline is a strange feature of GNU C. Can you guess what the -following code computes? -
    
-extern inline foo(void) { return 1; }
-int firstuse(void) { return foo(); }
-
-// A second, incompatible definition of foo
-int foo(void) { return 2; }
-
-int main() {
-    return foo() + firstuse();
-}
-
    -See the CIL output for this -code fragment
    -
    -The answer depends on whether the optimizations are turned on. If they are -then the answer is 3 (the first definition is inlined at all occurrences until -the second definition). If the optimizations are off, then the first -definition is ignore (treated like a prototype) and the answer is 4.
    -
    -CIL will misbehave on this example, if the optimizations are turned off (it - always returns 3).
    -
    -
  6. GCC allows you to cast an object of a type T into a union as long as the -union has a field of that type: -
    
-union u { 
-   int i; 
-   struct s { 
-      int i1, i2;
-   } s;
-};
-
-union u x = (union u)6;
-
-int main() {
-  struct s y = {1, 2};
-  union u  z = (union u)y;
-}
-
    -See the CIL output for this -code fragment
    -
    -
  7. GCC allows you to use the __mode__ attribute to specify the size -of the integer instead of the standard char, short and so on: -
    
-int __attribute__ ((__mode__ (  __QI__ ))) i8;
-int __attribute__ ((__mode__ (  __HI__ ))) i16;
-int __attribute__ ((__mode__ (  __SI__ ))) i32;
-int __attribute__ ((__mode__ (  __DI__ ))) i64;
-
    -See the CIL output for this -code fragment
    -
    -
  8. The “alias” attribute on a function declaration tells the - linker to treat this declaration as another name for the specified - function. CIL will replace the declaration with a trampoline - function pointing to the specified target. -
    
-    static int bar(int x, char y) {
-      return x + y;
-    }
-
-    //foo is considered another name for bar.
-    int foo(int x, char y) __attribute__((alias("bar")));
-
    -See the CIL output for this -code fragment
- - -

16.3  Microsoft VC ugliness

- -This compiler has few extensions, so there is not much to say here. -
  1. -Why does the following code return 0 and not -1? (Answer: because of a -bug in Microsoft Visual C. It thinks that the shift is unsigned just because -the second operator is unsigned. CIL reproduces this bug when in MSVC mode.) -
    
- return -3 >> (8 * sizeof(int));
-

    -
    -
  2. Unnamed fields in a structure seem really strange at first. It seems -that Microsoft Visual C introduced this extension, then GCC picked it up (but -in the process implemented it wrongly: in GCC the field y overlaps with -x!). -
    
-struct {
-  int x;
-  struct {
-     int y, z;
-     struct {
-       int u, v;
-     };
- };
-} a;
-return a.x + a.y + a.z + a.u + a.v;
-
    -See the CIL output for this -code fragment
- - -

17  Authors

- -The CIL parser was developed starting from Hugues Casse's frontc -front-end for C although all the files from the frontc distribution have -been changed very extensively. The intermediate language and the elaboration -stage are all written from scratch. The main author is -George Necula, with significant -contributions from Scott McPeak, -Westley Weimer, -Ben Liblit, -Matt Harren, -Raymond To and Aman Bhargava.
-
-This work is based upon work supported in part by the National Science -Foundation under Grants No. 9875171, 0085949 and 0081588, and gifts from -Microsoft Research. Any opinions, findings, and conclusions or recommendations -expressed in this material are those of the author(s) and do not necessarily -reflect the views of the National Science Foundation or the other sponsors.
-
- - -

18  License

- -Copyright (c) 2001-2005, -
  • -George C. Necula <necula@cs.berkeley.edu> -
  • Scott McPeak <smcpeak@cs.berkeley.edu> -
  • Wes Weimer <weimer@cs.berkeley.edu> -
  • Ben Liblit <liblit@cs.wisc.edu> -
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met:
-
-1. Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer.
-
-2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution.
-
-3. The names of the contributors may not be used to endorse or promote -products derived from this software without specific prior written -permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE.
-
- - -

19  Bug reports

- -We are certain that there are still some remaining bugs in CIL. If you find -one please file a bug report in our Source Forge space -http://sourceforge.net/projects/cil.
-
-You can find there the latest announcements, a source distribution, -bug report submission instructions and a mailing list: cil-users[at -sign]lists.sourceforge.net. Please use this list to ask questions about CIL, -as it will ensure your message is viewed by a broad audience.
-
- - -

20  Changes

- - -
  • -May 20, 2006: Released version 1.3.5 -
  • May 19, 2006: Makefile.cil.in/Makefile.cil have - been renamed Makefile.in/Makefile. And maincil.ml has - been renamed main.ml. -
  • May 18, 2006: Added a new module Cfg to compute the - control-flow graph. Unlike the older Cil.computeCFGInfo, - the new version does not modify the code. -
  • May 18, 2006: Added several new analyses: reaching - definitions, available expressions, liveness analysis, and dead code - elimination. See Section 8. -
  • May 2, 2006: Added a flag --noInsertImplicitCasts. - When this flag is used, CIL code will only include casts inserted by - the programmer. Implicit coercions are not changed to explicit casts. -
  • April 16, 2006: Minor improvements to the --stats - flag (Section 7.2). We now use Pentium performance - counters by default, if your processor supports them. -
  • April 10, 2006: Extended machdep.c to support - microcontroller compilers where the struct alignment of integer - types does not match the size of the type. Thanks to Nathan - Cooprider for the patch. -
  • April 6, 2006: Fix for global initializers of unions when - the union field being initialized is not the first one, and for - missing initializers of unions when the first field is not the - largest field. -
  • April 6, 2006: Fix for bitfields in the SFI module. -
  • April 6, 2006: Various fixes for gcc attributes. - packed, section, and always_inline attributes are now - parsed correctly. Also fixed printing of attributes on enum types. -
  • March 30, 2006: Fix for rmtemps.ml, which deletes - unused inline functions. When in gcc mode CIL now leaves all - inline functions in place, since gcc treats these as externally - visible. -
  • March 15, 2006: Fix for typeof(e) when e has type - void. -
  • March 3, 2006: Assume inline assembly instructions can - fall through for the purposes of adding return statements. Thanks to - Nathan Cooprider for the patch. -
  • February 27, 2006: Fix for extern inline functions when - the output of CIL is fed back into CIL. -
  • January 30, 2006: Fix parsing of switch without braces. -
  • January 30, 2006: Allow `$' to appear in identifiers. -
  • January 13, 2006: Added support for gcc's alias attribute - on functions. See Section 16.2, item 8. -
  • December 9, 2005: Christoph Spiel fixed the Golf and - Olf modules so that Golf can be used with the points-to analysis. - He also added performance fixes and cleaned up the documentation. -
  • December 1, 2005: Major rewrite of the ext/callgraph module. -
  • December 1, 2005: Preserve enumeration constants in CIL. Default -is the old behavior to replace them with integers. -
  • November 30, 2005: Added support for many GCC __builtin - functions. -
  • November 30, 2005: Added the EXTRAFEATURES configure - option, making it easier to add Features to the build process. -
  • November 23, 2005: In MSVC mode do not remove any locals whose name - appears as a substring in an inline assembly. -
  • November 23, 2005: Do not add a return to functions that have the - noreturn attribute. -
  • November 22, 2005: Released version 1.3.4 -
  • November 21, 2005: Performance and correctness fixes for - the Points-to Analysis module. Thanks to Christoph Spiel for the - patches. -
  • October 5, 2005: CIL now builds on SPARC/Solaris. Thanks - to Nick Petroni and Remco van Engelen for the patches. -
  • September 26, 2005: CIL no longer uses the `-I-' flag - by default when preprocessing with gcc. -
  • August 24, 2005: Added a command-line option - “--forceRLArgEval” that forces function arguments to be evaluated - right-to-left. This is the default behavior in unoptimized gcc and - MSVC, but the order of evaluation is undefined when using - optimizations, unless you apply this CIL transformation. This flag - does not affect the order of evaluation of e.g. binary operators, - which remains undefined. Thanks to Nathan Cooprider for the patch. -
  • August 9, 2005: Fixed merging when there are more than 20 - input files. -
  • August 3, 2005: When merging, it is now an error to - declare the same global variable twice with different initializers. -
  • July 27, 2005: Fixed bug in transparent unions. -
  • July 27, 2005: Fixed bug in collectInitializer. Thanks to - Benjamin Monate for the patch. -
  • July 26, 2005: Better support for extended inline assembly - in gcc. -
  • July 26, 2005: Added many more gcc __builtin* functions - to CIL. Most are treated as Call instructions, but a few are - translated into expressions so that they can be used in global - initializers. For example, “__builtin_offsetof(t, field)” is - rewritten as “&((t*)0)->field”, the traditional way of calculating - an offset. -
  • July 18, 2005: Fixed bug in the constant folding of shifts - when the second argument was negative or too large. -
  • July 18, 2005: Fixed bug where casts were not always - inserted in function calls. -
  • June 10, 2005: Fixed bug in the code that makes implicit - returns explicit. We weren't handling switch blocks correctly. -
  • June 1, 2005: Released version 1.3.3 -
  • May 31, 2005: Fixed handling of noreturn attribute for function - pointers. -
  • May 30, 2005: Fixed bugs in the handling of constructors in gcc. -
  • May 30, 2005: Fixed bugs in the generation of global variable IDs. -
  • May 27, 2005: Reimplemented the translation of function calls so - that we can intercept some builtins. This is important for the uses of - __builtin_constant_p in constants. -
  • May 27, 2005: Export the plainCilPrinter, for debugging. -
  • May 27, 2005: Fixed bug with printing of const attribute for - arrays. -
  • May 27, 2005: Fixed bug in generation of type signatures. Now they - should not contain expressions anymore, so you can use structural equality. - This used to lead to Out_of_Memory exceptions. -
  • May 27, 2005: Fixed bug in type comparisons using - TBuiltin_va_list. -
  • May 27, 2005: Improved the constant folding in array lengths and - case expressions. -
  • May 27, 2005: Added the __builtin_frame_address to the set - of gcc builtins. -
  • May 27, 2005: Added the CIL project to SourceForge. -
  • April 23, 2005: The cattr field was not visited. -
  • March 6, 2005: Debian packaging support -
  • February 16, 2005: Merger fixes. -
  • February 11, 2005: Fixed a bug in --dopartial. Thanks to -Nathan Cooprider for this fix. -
  • January 31, 2005: Make sure the input file is closed even if a - parsing error is encountered. -
  • January 11, 2005: Released version 1.3.2 -
  • January 11, 2005: Fixed printing of integer constants whose - integer kind is shorter than an int. -
  • January 11, 2005: Added checks for negative size arrays and arrays - too big. -
  • January 10, 2005: Added support for GCC attribute “volatile” for - tunctions (as a synonim for noreturn). -
  • January 10, 2005: Improved the comparison of array sizes when - comparing array types. -
  • January 10, 2005: Fixed handling of shell metacharacters in the - cilly command lione. -
  • January 10, 2005: Fixed dropping of cast in initialization of - local variable with the result of a function call. -
  • January 10, 2005: Fixed some structural comparisons that were - broken in the Ocaml 3.08. -
  • January 10, 2005: Fixed the unrollType function to not forget - attributes. -
  • January 10, 2005: Better keeping track of locations of function - prototypes and definitions. -
  • January 10, 2005: Fixed bug with the expansion of enumeration - constants in attributes. -
  • October 18, 2004: Fixed a bug in cabsvisit.ml. CIl would wrap a - BLOCK around a single atom unnecessarily. -
  • August 7, 2004: Released version 1.3.1 -
  • August 4, 2004: Fixed a bug in splitting of structs using - --dosimplify -
  • July 29, 2004: Minor changes to the type typeSig (type signatures) - to ensure that they do not contain types, so that you can do structural - comparison without danger of nontermination. -
  • July 28, 2004: Ocaml version 3.08 is required. Numerous small - changes while porting to Ocaml 3.08. -
  • July 7, 2004: Released version 1.2.6 -
  • July 2, 2004: Character constants such as 'c' should - have type int, not char. Added a utility function - Cil.charConstToInt that sign-extends chars greater than 128, if needed. -
  • July 2, 2004: Fixed a bug that was casting values to int - before applying the logical negation operator !. This caused - problems for floats, and for integer types bigger than int. -
  • June 13, 2004: Added the field sallstmts to a function - description, to hold all statements in the function. -
  • June 13, 2004: Added new extensions for data flow analyses, and - for computing dominators. -
  • June 10, 2004: Force initialization of CIL at the start of -Cabs2cil. -
  • June 9, 2004: Added support for GCC __attribute_used__ -
  • April 7, 2004: Released version 1.2.5 -
  • April 7, 2004: Allow now to run ./configure CC=cl and set the MSVC -compiler to be the default. The MSVC driver will now select the default name -of the .exe file like the CL compiler. -
  • April 7, 2004: Fixed a bug in the driver. The temporary files are -deleted by the Perl script before the CL compiler gets to them? -
  • April 7, 2004: Added the - form of arguments to the MSVC driver. -
  • April 7, 2004: Added a few more GCC-specific string escapes, (, [, -{, %, E. -
  • April 7, 2004: Fixed bug with continuation lines in MSVC. -
  • April 6, 2004: Fixed embarassing bug in the parser: the precedence - of casts and unary operators was switched. -
  • April 5, 2004: Fixed a bug involving statements mixed between -declarations containing initializers. Now we make sure that the initializers -are run in the proper order with respect to the statements. -
  • April 5, 2004: Fixed a bug in the merger. The merger was keeping -separate alpha renaming talbes (namespaces) for variables and types. This -means that it might end up with a type and a variable named the same way, if -they come from different files, which breaks an important CIL invariant. -
  • March 11, 2004 : Fixed a bug in the Cil.copyFunction function. The -new local variables were not getting fresh IDs. -
  • March 5, 2004: Fixed a bug in the handling of static function - prototypes in a block scope. They used to be renamed. Now we just consider - them global. -
  • February 20, 2004: Released version 1.2.4 -
  • February 15, 2004: Changed the parser to allow extra semicolons - after field declarations. -
  • February 14, 2004: Changed the Errormsg functions: error, unimp, -bug to not raise an exception. Instead they just set Errormsg.hadErrors. -
  • February 13, 2004: Change the parsing of attributes to recognize - enumeration constants. -
  • February 10, 2004: In some versions of gcc the identifier - _{thread is an identifier and in others it is a keyword. Added code - during configuration to detect which is the case. -
  • January 7, 2004: Released version 1.2.3 -
  • January 7, 2004: Changed the alpha renamer to be less -conservative. It will remember all versions of a name that were seen and will -only create a new name if we have not seen one. -
  • December 30, 2003 : Extended the cilly command to understand - better linker command options -lfoo. -
  • December 5, 2003: Added markup commands to the pretty-printer -module. Also, changed the “@<” left-flush command into “@''. -
  • December 4, 2003: Wide string literals are now handled -directly by Cil (rather than being exploded into arrays). This is -apparently handy for Microsoft Device Driver APIs that use intrinsic -functions that require literal constant wide-string arguments. -
  • December 3, 2003: Added support for structured exception handling - extensions for the Microsoft compilers. -
  • December 1, 2003: Fixed a Makefile bug in the generation of the -Cil library (e.g., cil.cma) that was causing it to be unusable. Thanks -to KEvin Millikin for pointing out this bug. -
  • November 26, 2003: Added support for linkage specifications - (extern “C”). -
  • November 26, 2003: Added the ocamlutil directory to contain some -utilities shared with other projects. -
  • November 25, 2003: Released version 1.2.2 -
  • November 24, 2003: Fixed a bug that allowed a static local to - conflict with a global with the same name that is declared later in the - file. -
  • November 24, 2003: Removed the --keep option of the cilly - driver and replaced it with --save-temps. -
  • November 24, 2003: Added printing of what CIL features are being - run. -
  • November 24, 2003: Fixed a bug that resulted in attributes being - dropped for integer types. -
  • November 11, 2003: Fixed a bug in the visitor for enumeration - definitions. -
  • October 24, 2003: Fixed a problem in the configuration script. It - was not recognizing the Ocaml version number for beta versions. -
  • October 15, 2003: Fixed a problem in version 1.2.1 that was - preventing compilation on OCaml 3.04. -
  • September 17, 2003: Released version 1.2.1. -
  • September 7, 2003: Redesigned the interface for choosing - #line directive printing styles. Cil.printLn and - Cil.printLnComment have been merged into Cil.lineDirectiveStyle. -
  • August 8, 2003: Do not silently pad out functions calls with -arguments to match the prototype. -
  • August 1, 2003: A variety of fixes suggested by Steve Chamberlain: -initializers for externs, prohibit float literals in enum, initializers for -unsized arrays were not working always, an overflow problem in Ocaml, changed -the processing of attributes before struct specifiers
    -
    -
  • July 14, 2003: Add basic support for GCC's "__thread" storage -qualifier. If given, it will appear as a "thread" attribute at the top of the -type of the declared object. Treatment is very similar to "__declspec(...)" -in MSVC
    -
    -
  • July 8, 2003: Fixed some of the __alignof computations. Fixed - bug in the designated initializers for arrays (Array.get error). -
  • July 8, 2003: Fixed infinite loop bug (Stack Overflow) in the - visitor for __alignof. -
  • July 8, 2003: Fixed bug in the conversion to CIL. A function or - array argument of - the GCC __typeof() was being converted to pointer type. Instead, it should - be left alone, just like for sizeof. -
  • July 7, 2003: New Escape module provides utility functions - for escaping characters and strings in accordance with C lexical - rules.
    -
    -
  • July 2, 2003: Relax CIL's rules for when two enumeration types are -considered compatible. Previously CIL considered two enums to be compatible if -they were the same enum. Now we follow the C99 standard.
    -
    -
  • June 28, 2003: In the Formatparse module, Eric Haugh found and - fixed a bug in the handling of lvalues of the form “lv->field.more”.
    -
    -
  • June 28, 2003: Extended the handling of gcc command lines -arguments in the Perl scripts.
    -
    -
  • June 23, 2003: In Rmtmps module, simplified the API for - customizing the root set. Clients may supply a predicate that - returns true for each root global. Modifying various - “referenced” fields directly is no longer supported.
    -
    -
  • June 17, 2003: Reimplement internal utility routine - Cil.escape_char. Faster and better.
    -
    -
  • June 14, 2003: Implemented support for __attribute__s -appearing between "struct" and the struct tag name (also for unions and -enums), since gcc supports this as documented in section 4.30 of the gcc -(2.95.3) manual
    -
    -
  • May 30, 2003: Released the regression tests. -
  • May 28, 2003: Released version 1.1.2 -
  • May 26, 2003: Add the simplify module that compiles CIL -expressions into simpler expressions, similar to those that appear in a -3-address intermediate language. -
  • May 26, 2003: Various fixes and improvements to the pointer -analysis modules. -
  • May 26, 2003: Added optional consistency checking for -transformations. -
  • May 25, 2003: Added configuration support for big endian machines. -Now Cil.little_endian can be used to test whether the machine is -little endian or not. -
  • May 22, 2003: Fixed a bug in the handling of inline functions. The -CIL merger used to turn these functions into “static”, which is incorrect. -
  • May 22, 2003: Expanded the CIL consistency checker to verify -undesired sharing relationships between data structures. -
  • May 22, 2003: Fixed bug in the oneret CIL module: it was -mishandling certain labeled return statements. -
  • May 5, 2003: Released version 1.0.11 -
  • May 5, 2003: OS X (powerpc/darwin) support for CIL. Special -thanks to Jeff Foster, Andy Begel and Tim Leek. -
  • April 30, 2003: Better description of how to use CIL for your -analysis. -
  • April 28, 2003: Fixed a bug with --dooneRet and ---doheapify. Thanks, Manos Renieris. -
  • April 16, 2003: Reworked management of - temporary/intermediate output files in Perl driver scripts. Default - behavior is now to remove all such files. To keep intermediate - files, use one of the following existing flags: -
    • - --keepmerged for the single-file merge of all sources -
    • --keep=<dir> for various other CIL and - CCured output files -
    • --save-temps for various gcc intermediate files; MSVC - has no equivalent option -
    - As part of this change, some intermediate files have changed their - names slightly so that new suffixes are always preceded by a - period. For example, CCured output that used to appear in - “foocured.c” now appears in “foo.cured.c”. -
  • April 7, 2003: Changed the representation of the Cil.GVar -global constructor. Now it is possible to update the initializer without -reconstructing the global (which in turn it would require reconstructing the -list of globals that make up a program). We did this because it is often -tempting to use Cil.visitCilFileSameGlobals and the Cil.GVar -was the only global that could not be updated in place. -
  • April 6, 2003: Reimplemented parts of the cilly.pl script to make -it more robust in the presence of complex compiler arguments. -
  • March 10, 2003: Released version 1.0.9 -
  • March 10, 2003: Unified and documented a large number of CIL -Library Modules: oneret, simplemem, makecfg, heapify, stackguard, partial. -Also documented the main client interface for the pointer analysis. -
  • February 18, 2003: Fixed a bug in logwrites that was causing it -to produce invalid C code on writes to bitfields. Thanks, David Park. -
  • February 15, 2003: Released version 1.0.8 -
  • February 15, 2003: PDF versions of the manual and API are -available for those who would like to print them out. -
  • February 14, 2003: CIL now comes bundled with alias analyses. -
  • February 11, 2003: Added support for adding/removing options from - ./configure. -
  • February 3, 2003: Released version 1.0.7 -
  • February 1, 2003: Some bug fixes in the handling of variable -argument functions in new versions of gcc And glibc. -
  • January 29, 2003: Added the logical AND and OR operators. -Exapanded the translation to CIL to handle more complicated initializers -(including those that contain logical operators). -
  • January 28, 2003: Released version 1.0.6 -
  • January 28, 2003: Added support for the new handling of -variable-argument functions in new versions of glibc. -
  • January 19, 2003: Added support for declarations in interpreted - constructors. Relaxed the semantics of the patterns for variables. -
  • January 17, 2003: Added built-in prototypes for the gcc built-in - functions. Changed the pGlobal method in the printers to print the - carriage return as well. -
  • January 9, 2003: Reworked lexer and parser's strategy for - tracking source file names and line numbers to more closely match - typical native compiler behavior. The visible CIL interface is - unchanged. -
  • January 9, 2003: Changed the interface to the alpha convertor. Now -you can pass a list where it will record undo information that you can use to -revert the changes that it makes to the scope tables. -
  • January 6, 2003: Released version 1.0.5 -
  • January 4, 2003: Changed the interface for the Formatcil module. - Now the placeholders in the pattern have names. Also expanded the - documentation of the Formatcil module. - Now the placeholders in the pattern have names. -
  • January 3, 2003: Extended the rmtmps module to also remove - unused labels that are generated in the conversion to CIL. This reduces the - number of warnings that you get from cgcc afterwards. -
  • December 17, 2002: Fixed a few bugs in CIL related to the - representation of string literals. The standard says that a string literal - is an array. In CIL, a string literal has type pointer to character. This is - Ok, except as an argument of sizeof. To support this exception, we have - added to CIL the expression constructor SizeOfStr. This allowed us to fix - bugs with computing sizeof("foo bar") and sizeof((char*)"foo bar") - (the former is 8 and the latter is 4).
    -
    -
  • December 8, 2002: Fixed a few bugs in the lexer and parser - relating to hex and octal escapes in string literals. Also fixed - the dependencies between the lexer and parser. -
  • December 5, 2002: Fixed visitor bugs that were causing - some attributes not to be visited and some queued instructions to be - dropped. -
  • December 3, 2002: Added a transformation to catch stack - overflows. Fixed the heapify transformation. -
  • October 14, 2002: CIL is now available under the BSD license -(see the License section or the file LICENSE). Released version 1.0.4 -
  • October 9, 2002: More FreeBSD configuration changes, support -for the GCC-ims __signed and __volatile. Thanks to Axel -Simon for pointing out these problems. Released version 1.0.3 -
  • October 8, 2002: FreeBSD configuration and porting fixes. -Thanks to Axel Simon for pointing out these problems. -
  • September 10, 2002: Fixed bug in conversion to CIL. Now we drop -all “const” qualifiers from the types of locals, even from the fields of -local structures or elements of arrays. -
  • September 7, 2002: Extended visitor interface to distinguish visitng - offsets inside lvalues from offsets inside initializer lists. -
  • September 7, 2002: Released version 1.0.1 -
  • September 6, 2002: Extended the patcher with the ateof flag. -
  • September 4, 2002: Fixed bug in the elaboration to CIL. In some -cases constant folding of || and && was computed wrong. -
  • September 3, 2002: Fixed the merger documentation. -
  • August 29, 2002: Released version 1.0.0. -
  • August 29, 2002: Started numbering versions with a major nubmer, -minor and revisions. Released version 1.0.0. -
  • August 25, 2002: Fixed the implementation of the unique -identifiers for global variables and composites. Now those identifiers are -globally unique. -
  • August 24, 2002: Added to the machine-dependent configuration the -sizeofvoid. It is 1 on gcc and 0 on MSVC. Extended the implementation of -Cil.bitsSizeOf to handle this (it was previously returning an error when -trying to compute the size of void). -
  • August 24, 2002: Changed the representation of structure and -unions to distinguish between undefined structures and those that are defined -to be empty (allowed on gcc). The sizeof operator is undefined for the former -and returns 0 for the latter. -
  • August 22, 2002: Apply a patch from Richard H. Y. to support -FreeBSD installations. Thanks, Richard! -
  • August 12, 2002: Fixed a bug in the translation of wide-character -strings. Now this translation matches that of the underlying compiler. Changed -the implementation of the compiler dependencies. -
  • May 25, 2002: Added interpreted constructors and destructors. -
  • May 17, 2002: Changed the representation of functions to move the -“inline” information to the varinfo. This way we can print the “inline” -even in declarations which is what gcc does. -
  • May 15, 2002: Changed the visitor for initializers to make two -tail-recursive passes (the second is a List.rev and only done if one of -the initializers change). This prevents Stack_Overflow for large -initializers. Also improved the processing of initializers when converting to -CIL. -
  • May 15, 2002: Changed the front-end to allow the use of MSVC -mode even on machines that do not have MSVC. The machine-dependent parameters -for GCC will be used in that case. -
  • May 11, 2002: Changed the representation of formals in function -types. Now the function type is purely functional. -
  • May 4, 2002: Added the function -Cil.visitCilFileSameGlobals and changed Cil.visitCilFile to be -tail recursive. This prevents stack overflow on huge files. -
  • February 28, 2002: Changed the significance of the -CompoundInit in Cil.init to allow for missing initializers at the -end of an array initializer. Added the API function -Cil.foldLeftCompoundAll. -
- - - -
This document was translated from LATEX by -HEVEA.
- diff --git a/cil/doc/cil.version.tex b/cil/doc/cil.version.tex deleted file mode 100644 index c584859..0000000 --- a/cil/doc/cil.version.tex +++ /dev/null @@ -1,2 +0,0 @@ -\def\cilversion{1.3.5} -\def\ccuredversion{@CCURED_VERSION@} diff --git a/cil/doc/cil001.html b/cil/doc/cil001.html deleted file mode 100644 index 5edc5da..0000000 --- a/cil/doc/cil001.html +++ /dev/null @@ -1,134 +0,0 @@ - - - - - - - - - - - - - -Introduction - - - -Up -Next -
- -

1  Introduction

-New: CIL now has a Source Forge page: - http://sourceforge.net/projects/cil.
-
-CIL (C Intermediate Language) is a high-level representation -along with a set of tools that permit easy analysis and source-to-source -transformation of C programs.
-
-CIL is both lower-level than abstract-syntax trees, by clarifying ambiguous -constructs and removing redundant ones, and also higher-level than typical -intermediate languages designed for compilation, by maintaining types and a -close relationship with the source program. The main advantage of CIL is that -it compiles all valid C programs into a few core constructs with a very clean -semantics. Also CIL has a syntax-directed type system that makes it easy to -analyze and manipulate C programs. Furthermore, the CIL front-end is able to -process not only ANSI-C programs but also those using Microsoft C or GNU C -extensions. If you do not use CIL and want instead to use just a C parser and -analyze programs expressed as abstract-syntax trees then your analysis will -have to handle a lot of ugly corners of the language (let alone the fact that -parsing C itself is not a trivial task). See Section 16 for some -examples of such extreme programs that CIL simplifies for you.
-
-In essence, CIL is a highly-structured, “clean” subset of C. CIL features a -reduced number of syntactic and conceptual forms. For example, all looping -constructs are reduced to a single form, all function bodies are given -explicit return statements, syntactic sugar like "->" is -eliminated and function arguments with array types become pointers. (For an -extensive list of how CIL simplifies C programs, see Section 4.) -This reduces the number of cases that must be considered when manipulating a C -program. CIL also separates type declarations from code and flattens scopes -within function bodies. This structures the program in a manner more amenable -to rapid analysis and transformation. CIL computes the types of all program -expressions, and makes all type promotions and casts explicit. CIL supports -all GCC and MSVC extensions except for nested functions and complex numbers. -Finally, CIL organizes C's imperative features into expressions, instructions -and statements based on the presence and absence of side-effects and -control-flow. Every statement can be annotated with successor and predecessor -information. Thus CIL provides an integrated program representation that can -be used with routines that require an AST (e.g. type-based analyses and -pretty-printers), as well as with routines that require a CFG (e.g., dataflow -analyses). CIL also supports even lower-level representations (e.g., -three-address code), see Section 8.
-
-CIL comes accompanied by a number of Perl scripts that perform generally -useful operations on code: -
  • -A driver which behaves as either the gcc or -Microsoft VC compiler and can invoke the preprocessor followed by the CIL -application. The advantage of this script is that you can easily use CIL and -the analyses written for CIL with existing make files. -
  • A whole-program merger that you can use as a -replacement for your compiler and it learns all the files you compile when you -make a project and merges all of the preprocessed source files into a single -one. This makes it easy to do whole-program analysis. -
  • A patcher makes it easy to create modified -copies of the system include files. The CIL driver can then be told to use -these patched copies instead of the standard ones. -
-CIL has been tested very extensively. It is able to process the SPECINT95 -benchmarks, the Linux kernel, GIMP and other open-source projects. All of -these programs are compiled to the simple CIL and then passed to gcc and -they still run! We consider the compilation of Linux a major feat especially -since Linux contains many of the ugly GCC extensions (see Section 16.2). -This adds to about 1,000,000 lines of code that we tested it on. It is also -able to process the few Microsoft NT device drivers that we have had access -to. CIL was tested against GCC's c-torture testsuite and (except for the tests -involving complex numbers and inner functions, which CIL does not currently -implement) CIL passes most of the tests. Specifically CIL fails 23 tests out -of the 904 c-torture tests that it should pass. GCC itself fails 19 tests. A -total of 1400 regression test cases are run automatically on each change to -the CIL sources.
-
-CIL is relatively independent on the underlying machine and compiler. When -you build it CIL will configure itself according to the underlying compiler. -However, CIL has only been tested on Intel x86 using the gcc compiler on Linux -and cygwin and using the MS Visual C compiler. (See below for specific -versions of these compilers that we have used CIL for.)
-
-The largest application we have used CIL for is -CCured, a compiler that compiles C code into -type-safe code by analyzing your pointer usage and inserting runtime checks in -the places that cannot be guaranteed statically to be type safe.
-
-You can also use CIL to “compile” code that uses GCC extensions (e.g. the -Linux kernel) into standard C code.
-
-CIL also comes accompanies by a growing library of extensions (see -Section 8). You can use these for your projects or as examples of -using CIL.
-
-PDF versions of this manual and the -CIL API are available. However, we recommend the -HTML versions because the postprocessed code examples are easier to -view.
-
-If you use CIL in your project, we would appreciate letting us know. If you -want to cite CIL in your research writings, please refer to the paper “CIL: -Intermediate Language and Tools for Analysis and Transformation of C -Programs” by George C. Necula, Scott McPeak, S.P. Rahul and Westley Weimer, -in “Proceedings of Conference on Compilier Construction”, 2002.
-
-
-Up -Next - - diff --git a/cil/doc/cil002.html b/cil/doc/cil002.html deleted file mode 100644 index e575ce3..0000000 --- a/cil/doc/cil002.html +++ /dev/null @@ -1,98 +0,0 @@ - - - - - - - - - - - - - -Installation - - - -Previous -Up -Next -
- -

2  Installation

-You will need OCaml release 3.08 or higher to build CIL. CIL has been tested -on Linux and on Windows (where it can behave at either Microsoft Visual C or -gcc).
-
-If you want to use CIL on Windows then you must get a complete installation -of cygwin and the source-code OCaml distribution and compile it yourself -using the cygwin tools (as opposed to getting the Win32 native-code version of -OCaml). If you have not done this before then take a look -here. (Don't need to worry about cvs and -ssh unless you will need to use the master CVS repository for CIL.) -
  1. -Download the CIL distribution (latest version is -distrib/cil-1.3.5.tar.gz). See the Section 20 for recent changes to the CIL distribution. -
  2. Unzip and untar the source distribution. This will create a directory - called cil whose structure is explained below.
    -tar xvfz cil-1.3.5.tar.gz -
  3. Enter the cil directory and run the configure script and then - GNU make to build the distribution. If you are on Windows, at least the - configure step must be run from within bash.
    -    cd cil
    -    ./configure
    -    make
    -    make quicktest
    -
  4. You should now find cilly.asm.exe in a -subdirectory of obj. The name of the subdirectory is either x86_WIN32 -if you are using cygwin on Windows or x86_LINUX if you are using -Linux (although you should be using instead the Perl wrapper bin/cilly). -Note that we do not have an install make target and you should use Cil -from the development directory. -
  5. If you decide to use CIL, please -send us a note. This will help recharge -our batteries after more than a year of development. And of course, do send us -your bug reports as well.
-The configure script tries to find appropriate defaults for your system. -You can control its actions by passing the following arguments: -
  • -CC=foo Specifies the path for the gcc executable. By default -whichever version is in the PATH is used. If CC specifies the Microsoft -cl compiler, then that compiler will be set as the default one. Otherwise, -the gcc compiler will be the default. -
-CIL requires an underlying C compiler and preprocessor. CIL depends on the -underlying compiler and machine for the sizes and alignment of types.The -installation procedure for CIL queries the underlying compiler for -architecture and compiler dependent configuration parameters, such as the size -of a pointer or the particular alignment rules for structure fields. (This -means, of course, that you should re-run ./configure when you move CIL to -another machine.)
-
-We have tested CIL on the following compilers: -
  • -On Windows, cl compiler version 12.00.8168 (MSVC 6), - 13.00.9466 (MSVC .Net), and 13.10.3077 (MSVC .Net 2003). Run cl - with no arguments to get the compiler version. -
  • On Windows, using cygwin and gcc version 2.95.3, 3.0, - 3.2, 3.3, and 3.4. -
  • On Linux, using gcc version 2.95.3, 3.0, 3.2, 3.3, and 4.0. -
-Others have successfully used CIL with Mac OS X (on both PowerPC and -x86), Solaris, and *BSD. If you make any changes to the build -system in order to run CIL on your platform, please send us a patch.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cil003.html b/cil/doc/cil003.html deleted file mode 100644 index 4b885f3..0000000 --- a/cil/doc/cil003.html +++ /dev/null @@ -1,187 +0,0 @@ - - - - - - - - - - - - - -Distribution Contents - - - -Previous -Up -Next -
- -

3  Distribution Contents

-The file distrib/cil-1.3.5.tar.gz -contains the complete source CIL distribution, -consisting of the following files:
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
FilenameDescription
Makefile.inconfigure source for the - Makefile that builds CIL
configureThe configure script
configure.inThe autoconf source for configure
config.guess, config.sub, install-shstuff required by - configure
 
doc/HTML documentation of the CIL API
obj/Directory that will contain the compiled - CIL modules and executables
bin/cilly.inThe configure source for a Perl script - that can be invoked with the - same arguments as either gcc or - Microsoft Visual C and will convert the - program to CIL, perform some simple - transformations, emit it and compile it as - usual.
lib/CompilerStub.pmA Perl class that can be used to write code - that impersonates a compiler. cilly - uses it.
lib/Merger.pmA subclass of CompilerStub.pm that can - be used to merge source files into a single - source file.cilly - uses it.
bin/patcher.inA Perl script that applies specified patches - to standard include files.
 
src/check.ml,mliChecks the well-formedness of a CIL file
src/cil.ml,mliDefinition of CIL abstract syntax and - utilities for manipulating it
src/clist.ml,mliUtilities for efficiently managing lists - that need to be concatenated often
src/errormsg.ml,mliUtilities for error reporting
src/ext/heapify.mlA CIL transformation that moves array local - variables from the stack to the heap
src/ext/logcalls.ml,mliA CIL transformation that logs every - function call
src/ext/sfi.mlA CIL transformation that can log every - memory read and write
src/frontc/clexer.mllThe lexer
src/frontc/cparser.mlyThe parser
src/frontc/cabs.mlThe abstract syntax
src/frontc/cprint.mlThe pretty printer for CABS
src/frontc/cabs2cil.mlThe elaborator to CIL
src/main.mlThe cilly application
src/pretty.ml,mliUtilities for pretty printing
src/rmtmps.ml,mliA CIL tranformation that removes unused - types, variables and inlined functions
src/stats.ml,mliUtilities for maintaining timing statistics
src/testcil.mlA random test of CIL (against the resident - C compiler)
src/trace.ml,mliUtilities useful for printing debugging - information
 
ocamlutil/Miscellaneous libraries that are not - specific to CIL.
ocamlutil/Makefile.ocamlA file that is included by Makefile
ocamlutil/Makefile.ocaml.buildA file that is included by Makefile
ocamlutil/perfcount.cC code that links with src/stats.ml - and reads Intel performance - counters.
 
obj/@ARCHOS@/feature_config.mlFile generated by the Makefile - describing which extra “features” - to compile. See Section 5
obj/@ARCHOS@/machdep.mlFile generated by the Makefile containing - information about your architecture, - such as the size of a pointer
src/machdep.cC program that generates - machdep.ml files

-
-Previous -Up -Next - - diff --git a/cil/doc/cil004.html b/cil/doc/cil004.html deleted file mode 100644 index 16fde39..0000000 --- a/cil/doc/cil004.html +++ /dev/null @@ -1,350 +0,0 @@ - - - - - - - - - - - - - -Compiling C to CIL - - - -Previous -Up -Next -
- -

4  Compiling C to CIL

-In this section we try to describe a few of the many transformations that are -applied to a C program to convert it to CIL. The module that implements this -conversion is about 5000 lines of OCaml code. In contrast a simple program -transformation that instruments all functions to keep a shadow stack of the -true return address (thus preventing stack smashing) is only 70 lines of code. -This example shows that the analysis is so much simpler because it has to -handle only a few simple C constructs and also because it can leverage on CIL -infrastructure such as visitors and pretty-printers.
-
-In no particular order these are a few of the most significant ways in which -C programs are compiled into CIL: -
  1. -CIL will eliminate all declarations for unused entities. This means that -just because your hello world program includes stdio.h it does not mean -that your analysis has to handle all the ugly stuff from stdio.h.
    -
    -
  2. Type specifiers are interpreted and normalized: -
    
-int long signed x;
-signed long extern x;
-long static int long y;
-
-// Some code that uses these declaration, so that CIL does not remove them
-int main() { return x + y; }
-
    -See the CIL output for this -code fragment
    -
    -
  3. Anonymous structure and union declarations are given a name. -
    
- struct { int x; } s;
-
    -See the CIL output for this -code fragment
    -
    -
  4. Nested structure tag definitions are pulled apart. This means that all -structure tag definitions can be found by a simple scan of the globals. -
    
-struct foo {
-   struct bar {
-      union baz { 
-          int x1; 
-          double x2;
-      } u1;
-      int y;
-   } s1;
-   int z;
-} f;
-
    -See the CIL output for this -code fragment
    -
    -
  5. All structure, union, enumeration definitions and the type definitions -from inners scopes are moved to global scope (with appropriate renaming). This -facilitates moving around of the references to these entities. -
    
-int main() {
-  struct foo { 
-        int x; } foo; 
-  {
-     struct foo { 
-        double d;
-     };
-     return foo.x;
-  }      
-}
-
    -See the CIL output for this -code fragment
    -
    -
  6. Prototypes are added for those functions that are called before being -defined. Furthermore, if a prototype exists but does not specify the type of -parameters that is fixed. But CIL will not be able to add prototypes for those -functions that are neither declared nor defined (but are used!). -
    
-  int f();  // Prototype without arguments
-  int f(double x) {
-      return g(x);
-  }
-  int g(double x) {
-     return x;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  7. Array lengths are computed based on the initializers or by constant -folding. -
    
-  int a1[] = {1,2,3};
-  int a2[sizeof(int) >= 4 ? 8 : 16];
-
    -See the CIL output for this -code fragment
    -
    -
  8. Enumeration tags are computed using constant folding: -
    
-int main() {
-  enum { 
-     FIVE = 5, 
-     SIX, SEVEN, 
-     FOUR = FIVE - 1, 
-     EIGHT = sizeof(double)
-  } x = FIVE;
- return x;
-}
-
-
    -See the CIL output for this -code fragment
    -
    -
  9. Initializers are normalized to include specific initialization for the -missing elements: -
    
-  int a1[5] = {1,2,3};
-  struct foo { int x, y; } s1 = { 4 };
-
    -See the CIL output for this -code fragment
    -
    -
  10. Initializer designators are interpreted and eliminated. Subobjects are -properly marked with braces. CIL implements -the whole ISO C99 specification for initializer (neither GCC nor MSVC do) and -a few GCC extensions. -
    
-  struct foo { 
-     int x, y; 
-     int a[5];
-     struct inner {
-        int z;
-     } inner;
-  } s = { 0, .inner.z = 3, .a[1 ... 2] = 5, 4, y : 8 };
-
    -See the CIL output for this -code fragment
    -
    -
  11. String initializers for arrays of characters are processed -
    
-char foo[] = "foo plus bar";
-
    -See the CIL output for this -code fragment
    -
    -
  12. String constants are concatenated -
    
-char *foo = "foo " " plus " " bar ";
-
    -See the CIL output for this -code fragment
    -
    -
  13. Initializers for local variables are turned into assignments. This is in -order to separate completely the declarative part of a function body from the -statements. This has the unfortunate effect that we have to drop the const -qualifier from local variables ! -
    
-  int x = 5; 
-  struct foo { int f1, f2; } a [] = {1, 2, 3, 4, 5 };
-
    -See the CIL output for this -code fragment
    -
    -
  14. Local variables in inner scopes are pulled to function scope (with -appropriate renaming). Local scopes thus disappear. This makes it easy to find -and operate on all local variables in a function. -
    
-  int x = 5; 
-  int main() {
-    int x = 6;
-    { 
-      int x = 7;
-      return x;
-    }
-    return x;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  15. Global declarations in local scopes are moved to global scope: -
    
-  int x = 5; 
-  int main() {
-    int x = 6;
-    { 
-      static int x = 7;
-      return x;
-    }
-    return x;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  16. Return statements are added for functions that are missing them. If the -return type is not a base type then a return without a value is added. -The guaranteed presence of return statements makes it easy to implement a -transformation that inserts some code to be executed immediately before -returning from a function. -
    
-  int foo() {
-    int x = 5;
-  } 
-
    -See the CIL output for this -code fragment
    -
    -
  17. One of the most significant transformations is that expressions that -contain side-effects are separated into statements. -
    
-   int x, f(int);
-   return (x ++ + f(x));
-
    -See the CIL output for this -code fragment
    -
    -Internally, the x ++ statement is turned into an assignment which the -pretty-printer prints like the original. CIL has only three forms of basic -statements: assignments, function calls and inline assembly.
    -
    -
  18. Shortcut evaluation of boolean expressions and the ?: operator are -compiled into explicit conditionals: -
    
-  int x;
-  int y = x ? 2 : 4;
-  int z = x || y;
-  // Here we duplicate the return statement
-  if(x && y) { return 0; } else { return 1; }
-  // To avoid excessive duplication, CIL uses goto's for 
-  // statement that have more than 5 instructions
-  if(x && y || z) { x ++; y ++; z ++; x ++; y ++; return z; }
-
    -See the CIL output for this -code fragment
    -
    -
  19. GCC's conditional expression with missing operands are also compiled -into conditionals: -
    
-  int f();;
-  return f() ? : 4;
-
    -See the CIL output for this -code fragment
    -
    -
  20. All forms of loops (while, for and do) are compiled -internally as a single while(1) looping construct with explicit break -statement for termination. For simple while loops the pretty printer is -able to print back the original: -
    
-   int x, y;
-   for(int i = 0; i<5; i++) {
-      if(i == 5) continue;
-      if(i == 4) break;
-      i += 2;
-   } 
-   while(x < 5) {
-     if(x == 3) continue;
-     x ++;
-   }
-
    -See the CIL output for this -code fragment
    -
    -
  21. GCC's block expressions are compiled away. (That's right there is an -infinite loop in this code.) -
    
-   int x = 5, y = x;
-   int z = ({ x++; L: y -= x; y;});
-   return ({ goto L; 0; });
-
    -See the CIL output for this -code fragment
    -
    -
  22. CIL contains support for both MSVC and GCC inline assembly (both in one -internal construct)
    -
    -
  23. CIL compiles away the GCC extension that allows many kinds of constructs -to be used as lvalues: -
    
-   int x, y, z;
-   return &(x ? y : z) - & (x ++, x);
-
    -See the CIL output for this -code fragment
    -
    -
  24. All types are computed and explicit casts are inserted for all -promotions and conversions that a compiler must insert:
    -
    -
  25. CIL will turn old-style function definition (without prototype) into -new-style definitions. This will make the compiler less forgiving when -checking function calls, and will catch for example cases when a function is -called with too few arguments. This happens in old-style code for the purpose -of implementing variable argument functions.
    -
    -
  26. Since CIL sees the source after preprocessing the code after CIL does -not contain the comments and the preprocessing directives.
    -
    -
  27. CIL will remove from the source file those type declarations, local -variables and inline functions that are not used in the file. This means that -your analysis does not have to see all the ugly stuff that comes from the -header files: -
    
-#include <stdio.h>
-
-typedef int unused_type;
-
-static char unused_static (void) { return 0; }
-
-int main() {
-  int unused_local;
-  printf("Hello world\n"); // Only printf will be kept from stdio.h     
-}
-
    -See the CIL output for this -code fragment
-
-Previous -Up -Next - - diff --git a/cil/doc/cil006.html b/cil/doc/cil006.html deleted file mode 100644 index 8fc3194..0000000 --- a/cil/doc/cil006.html +++ /dev/null @@ -1,627 +0,0 @@ - - - - - - - - - - - - - -CIL API Documentation - - - -Previous -Up -Next -
- -

6  CIL API Documentation

-The CIL API is documented in the file src/cil.mli. We also have an -online documentation extracted from cil.mli. We -index below the main types that are used to represent C programs in CIL: - - -

6.1  Using the visitor

-One of the most useful tools exported by the CIL API is an implementation of -the visitor pattern for CIL programs. The visiting engine scans depth-first -the structure of a CIL program and at each node is queries a user-provided -visitor structure whether it should do one of the following operations: -
  • -Ignore this node and all its descendants -
  • Descend into all of the children and when done rebuild the node if any -of the children have changed. -
  • Replace the subtree rooted at the node with another tree. -
  • Replace the subtree with another tree, then descend into the children -and rebuild the node if necessary and then invoke a user-specified function. -
  • In addition to all of the above actions then visitor can specify that -some instructions should be queued to be inserted before the current -instruction or statement being visited. -
-By writing visitors you can customize the program traversal and -transformation. One major limitation of the visiting engine is that it does -not propagate information from one node to another. Each visitor must use its -own private data to achieve this effect if necessary.
-
-Each visitor is an object that is an instance of a class of type Cil.cilVisitor.. -The most convenient way to obtain such classes is to specialize the -Cil.nopCilVisitor.class (which just traverses the tree doing -nothing). Any given specialization typically overrides only a few of the -methods. Take a look for example at the visitor defined in the module -logwrites.ml. Another, more elaborate example of a visitor is the -[copyFunctionVisitor] defined in cil.ml.
-
-Once you have defined a visitor you can invoke it with one of the functions: - -Some transformations may want to use visitors to insert additional -instructions before statements and instructions. To do so, pass a list of -instructions to the Cil.queueInstr method of the specialized -object. The instructions will automatically be inserted before that -instruction in the transformed code. The Cil.unqueueInstr method -should not normally be called by the user.
-
- -

6.2  Interpreted Constructors and Deconstructors

-Interpreted constructors and deconstructors are a facility for constructing -and deconstructing CIL constructs using a pattern with holes that can be -filled with a variety of kinds of elements. The pattern is a string that uses -the C syntax to represent C language elements. For example, the following -code: -

-Formatcil.cType "void * const (*)(int x)"
-
-is an alternative way to construct the internal representation of the type of pointer to function -with an integer argument and a void * const as result: -

-TPtr(TFun(TVoid [Attr("const", [])],
-          [ ("x", TInt(IInt, []), []) ], false, []), [])
-
-The advantage of the interpreted constructors is that you can use familiar C -syntax to construct CIL abstract-syntax trees.
-
-You can construct this way types, lvalues, expressions, instructions and -statements. The pattern string can also contain a number of placeholders that -are replaced during construction with CIL items passed as additional argument -to the construction function. For example, the %e:id placeholder means -that the argument labeled “id” (expected to be of form Fe exp) will -supply the expression to replace the placeholder. For example, the following -code constructs an increment instruction at location loc: -

-Formatcil.cInstr "%v:x = %v:x + %e:something"
-        loc
-        [ ("something", Fe some_exp);
-          ("x", Fv some_varinfo) ]
-
-An alternative way to construct the same CIL instruction is: -

-Set((Var some_varinfo, NoOffset),
-    BinOp(PlusA, Lval (Var some_varinfo, NoOffset),
-          some_exp, intType), 
-    loc)
-
-See Cil.formatArg for a definition of the placeholders that are -understood.
-
-A dual feature is the interpreted deconstructors. This can be used to test -whether a CIL construct has a certain form: -

-Formatcil.dType "void * const (*)(int x)" t
-
-will test whether the actual argument t is indeed a function pointer of -the required type. If it is then the result is Some [] otherwise it is -None. Furthermore, for the purpose of the interpreted deconstructors -placeholders in patterns match anything of the right type. For example, -

-Formatcil.dType "void * (*)(%F:t)" t
-
-will match any function pointer type, independent of the type and number of -the formals. If the match succeeds the result is Some [ FF forms ] where -forms is a list of names and types of the formals. Note that each member -in the resulting list corresponds positionally to a placeholder in the -pattern.
-
-The interpreted constructors and deconstructors do not support the complete C -syntax, but only a substantial fragment chosen to simplify the parsing. The -following is the syntax that is supported: -
-Expressions:
-  E ::= %e:ID | %d:ID | %g:ID | n | L | ( E ) | Unop E | E Binop E 
-        | sizeof E | sizeof ( T ) | alignof E  | alignof ( T ) 
-        | & L | ( T ) E 
-
-Unary operators:
-  Unop ::= + | - | ~ | %u:ID
-
-Binary operators:
-  Binop ::= + | - | * | / | << | >> | & | ``|'' | ^ 
-          | == | != | < | > | <= | >= | %b:ID
-
-Lvalues:
-  L ::= %l:ID | %v:ID Offset | * E | (* E) Offset | E -> ident Offset 
-
-Offsets:
-  Offset ::= empty | %o:ID | . ident Offset | [ E ] Offset
-
-Types:
-  T ::= Type_spec Attrs Decl
-
-Type specifiers:
-  Type_spec ::= void | char | unsigned char | short | unsigned short
-            | int | unsigned int | long | unsigned long | %k:ID | float 
-            | double | struct %c:ID | union %c:ID 
-
-
-Declarators:
-  Decl ::= * Attrs Decl | Direct_decl
-
-
-Direct declarators:
-  Direct_decl ::= empty | ident | ( Attrs Decl ) 
-                 | Direct_decl [ Exp_opt ]
-                 | ( Attrs Decl )( Parameters )
-
-Optional expressions
-  Exp_opt ::= empty | E | %eo:ID
-
-Formal parameters
-  Parameters ::= empty | ... | %va:ID | %f:ID | T | T , Parameters
-
-List of attributes
-  Attrs ::= empty | %A:ID | Attrib Attrs
-
-Attributes
-  Attrib ::= const | restrict | volatile | __attribute__ ( ( GAttr ) )
-
-GCC Attributes
-  GAttr ::= ident | ident ( AttrArg_List )
-
-Lists of GCC Attribute arguments:
-  AttrArg_List ::= AttrArg | %P:ID | AttrArg , AttrArg_List
-
-GCC Attribute arguments  
-  AttrArg ::= %p:ID | ident | ident ( AttrArg_List )
-
-Instructions
-  Instr ::= %i:ID ; | L = E ; | L Binop= E | Callres L ( Args )
-
-Actual arguments
-   Args ::= empty | %E:ID | E | E , Args
-
-Call destination
-   Callres ::= empty | L = | %lo:ID
-
-Statements
-  Stmt ::= %s:ID | if ( E ) then Stmt ; | if ( E ) then Stmt else Stmt ;
-       | return Exp_opt | break ; | continue ; | { Stmt_list } 
-       | while (E ) Stmt | Instr_list 
-
-Lists of statements
-   Stmt_list ::= empty | %S:ID | Stmt Stmt_list  
-                | Type_spec Attrs Decl ; Stmt_list
-                | Type_spec Attrs Decl = E ; Stmt_list
-                | Type_spec Attrs Decl = L (Args) ; Stmt_list
-
-List of instructions
-   Instr_list ::= Instr | %I:ID | Instr Instr_list
-
-Notes regarding the syntax: -
  • -In the grammar description above non-terminals are written with -uppercase initial
    -
    -
  • All of the patterns consist of the % character followed by one or -two letters, followed by “:” and an indentifier. For each such -pattern there is a corresponding constructor of the Cil.formatArg -type, whose name is the letter 'F' followed by the same one or two letters as -in the pattern. That constructor is used by the user code to pass a -Cil.formatArg actual argument to the interpreted constructor and by -the interpreted deconstructor to return what was matched for a pattern.
    -
    -
  • If the pattern name is uppercase, it designates a list of the elements -designated by the corresponding lowercase pattern. E.g. %E designated lists -of expressions (as in the actual arguments of a call).
    -
    -
  • The two-letter patterns whose second letter is “o” designate an -optional element. E.g. %eo designates an optional expression (as in the -length of an array).
    -
    -
  • Unlike in calls to printf, the pattern %g is used for strings.
    -
    -
  • The usual precedence and associativity rules as in C apply
    -
    -
  • The pattern string can contain newlines and comments, using both the -/* ... */ style as well as the // one.
    -
    -
  • When matching a “cast” pattern of the form ( T ) E, the -deconstructor will match even expressions that do not have the actual cast but -in that case the type is matched against the type of the expression. E.g. the -patters "(int)%e" will match any expression of type int whether it -has an explicit cast or not.
    -
    -
  • The %k pattern is used to construct and deconstruct an integer type of -any kind.
    -
    -
  • Notice that the syntax of types and declaration are the same (in order -to simplify the parser). This means that technically you can write a whole -declaration instead of a type in the cast. In this case the name that you -declare is ignored.
    -
    -
  • In lists of formal parameters and lists of attributes, an empty list in -the pattern matches any formal parameters or attributes.
    -
    -
  • When matching types, uses of named types are unrolled to expose a real -type before matching.
    -
    -
  • The order of the attributes is ignored during matching. The the pattern -for a list of attributes contains %A then the resulting formatArg will be -bound to all attributes in the list. For example, the pattern "const -%A" matches any list of attributes that contains const and binds the -corresponding placeholder to the entire list of attributes, including -const.
    -
    -
  • All instruction-patterns must be terminated by semicolon
    -
    -
  • The autoincrement and autodecrement instructions are not supported. Also -not supported are complex expressions, the && and || shortcut -operators, and a number of other more complex instructions or statements. In -general, the patterns support only constructs that can be represented directly -in CIL.
    -
    -
  • The pattern argument identifiers are not used during deconstruction. -Instead, the result contains a sequence of values in the same order as the -appearance of pattern arguments in the pattern.
    -
    -
  • You can mix statements with declarations. For each declaration a new - temporary will be constructed (using a function you provive). You can then - refer to that temporary by name in the rest of the pattern.
    -
    -
  • The %v: pattern specifier is optional. -
-The following function are defined in the Formatcil module for -constructing and deconstructing: - -Below is an example using interpreted constructors. This example generates -the CIL representation of code that scans an array backwards and initializes -every even-index element with an expression: -

-Formatcil.cStmts
-  loc
-  "int idx = sizeof(array) / sizeof(array[0]) - 1;
-   while(idx >= 0) {
-     // Some statements to be run for all the elements of the array
-     %S:init
-     if(! (idx & 1)) 
-       array[idx] = %e:init_even;
-     /* Do not forget to decrement the index variable */
-     idx = idx - 1;
-   }"
-  (fun n t -> makeTempVar myfunc ~name:n t)
-  [ ("array", Fv myarray); 
-    ("init", FS [stmt1; stmt2; stmt3]);
-    ("init_even", Fe init_expr_for_even_elements) ]
-
-To write the same CIL statement directly in CIL would take much more effort. -Note that the pattern is parsed only once and the result (a function that -takes the arguments and constructs the statement) is memoized.
-
- -

6.2.1  Performance considerations for interpreted constructors

-Parsing the patterns is done with a LALR parser and it takes some time. To -improve performance the constructors and deconstructors memoize the parsed -patterns and will only compile a pattern once. Also all construction and -deconstruction functions can be applied partially to the pattern string to -produce a function that can be later used directly to construct or -deconstruct. This function appears to be about two times slower than if the -construction is done using the CIL constructors (without memoization the -process would be one order of magnitude slower.) However, the convenience of -interpreted constructor might make them a viable choice in many situations -when performance is not paramount (e.g. prototyping).
-
- -

6.3  Printing and Debugging support

-The Modules Pretty and Errormsg contain respectively -utilities for pretty printing and reporting errors and provide a convenient -printf-like interface.
-
-Additionally, CIL defines for each major type a pretty-printing function that -you can use in conjunction with the Pretty interface. The -following are some of the pretty-printing functions: - -You can even customize the pretty-printer by creating instances of -Cil.cilPrinter.. Typically such an instance extends -Cil.defaultCilPrinter. Once you have a customized pretty-printer you -can use the following printing functions: - -CIL has certain internal consistency invariants. For example, all references -to a global variable must point to the same varinfo structure. This -ensures that one can rename the variable by changing the name in the -varinfo. These constraints are mentioned in the API documentation. There -is also a consistency checker in file src/check.ml. If you suspect that -your transformation is breaking these constraints then you can pass the ---check option to cilly and this will ensure that the consistency checker -is run after each transformation.
-
- -

6.4  Attributes

-In CIL you can attach attributes to types and to names (variables, functions -and fields). Attributes are represented using the type Cil.attribute. -An attribute consists of a name and a number of arguments (represented using -the type Cil.attrparam). Almost any expression can be used as an -attribute argument. Attributes are stored in lists sorted by the name of the -attribute. To maintain list ordering, use the functions -Cil.typeAttrs to retrieve the attributes of a type and the functions -Cil.addAttribute and Cil.addAttributes to add attributes. -Alternatively you can use Cil.typeAddAttributes to add an attribute to -a type (and return the new type).
-
-GCC already has extensive support for attributes, and CIL extends this -support to user-defined attributes. A GCC attribute has the syntax: -
- gccattribute ::= __attribute__((attribute))    (Note the double parentheses)
-
- Since GCC and MSVC both support various flavors of each attribute (with or -without leading or trailing _) we first strip ALL leading and trailing _ -from the attribute name (but not the identified in [ACons] parameters in -Cil.attrparam). When we print attributes, for GCC we add two leading -and two trailing _; for MSVC we add just two leading _.
-
-There is support in CIL so that you can control the printing of attributes -(see Cil.setCustomPrintAttribute and -Cil.setCustomPrintAttributeScope). This custom-printing support is now -used to print the "const" qualifier as "const" and not as -"__attribute__((const))".
-
-The attributes are specified in declarations. This is unfortunate since the C -syntax for declarations is already quite complicated and after writing the -parser and elaborator for declarations I am convinced that few C programmers -understand it completely. Anyway, this seems to be the easiest way to support -attributes.
-
-Name attributes must be specified at the very end of the declaration, just -before the = for the initializer or before the , the separates a -declaration in a group of declarations or just before the ; that -terminates the declaration. A name attribute for a function being defined can -be specified just before the brace that starts the function body.
-
-For example (in the following examples A1,...,An are type attributes -and N is a name attribute (each of these uses the __attribute__ syntax): -

- int x N;
- int x N, * y N = 0, z[] N;
- extern void exit() N;
- int fact(int x) N { ... }
-
-Type attributes can be specified along with the type using the following - rules: -
  1. - The type attributes for a base type (int, float, named type, reference - to struct or union or enum) must be specified immediately following the - type (actually it is Ok to mix attributes with the specification of the - type, in between unsigned and int for example).
    -
    -For example: -
    
-  int A1 x N;  /* A1 applies to the type int. An example is an attribute
-                   "even" restricting the type int to even values. */
-  struct foo A1 A2 x; // Both A1 and A2 apply to the struct foo type
-

    -
    -
  2. The type attributes for a pointer type must be specified immediately - after the * symbol. -
    
- /* A pointer (A1) to an int (A2) */
- int A2 * A1 x;
- /* A pointer (A1) to a pointer (A2) to a float (A3) */
- float A3 * A2 * A1 x;
-
    -Note: The attributes for base types and for pointer types are a strict - extension of the ANSI C type qualifiers (const, volatile and restrict). In - fact CIL treats these qualifiers as attributes.
    -
    -
  3. The attributes for a function type or for an array type can be - specified using parenthesized declarators.
    -
    -For example: -
    
-   /* A function (A1) from int (A2) to float (A3) */
-   float A3 (A1 f)(int A2);
-
-   /* A pointer (A1) to a function (A2) that returns an int (A3) */
-   int A3 (A2 * A1 pfun)(void);
-
-   /* An array (A1) of int (A2) */
-   int A2 (A1 x0)[]
-
-   /* Array (A1) of pointers (A2) to functions (A3) that take an int (A4) and 
-    * return a pointer (A5) to int (A6)  */
-   int A6 * A5 (A3 * A2 (A1 x1)[5])(int A4);
-
-
-   /* A function (A4) that takes a float (A5) and returns a pointer (A6) to an 
-    * int (A7) */
-   extern int A7 * A6 (A4 x2)(float A5 x);
-
-   /* A function (A1) that takes a int (A2) and that returns a pointer (A3) to 
-    * a function (A4) that takes a float (A5) and returns a pointer (A6) to an 
-    * int (A7) */
-   int A7 * A6 (A4 * A3 (A1 x3)(int A2 x))(float A5) {
-      return & x2;
-   }
-
-Note: ANSI C does not allow the specification of type qualifiers for function -and array types, although it allows for the parenthesized declarator. With -just a bit of thought (looking at the first few examples above) I hope that -the placement of attributes for function and array types will seem intuitive.
-
-This extension is not without problems however. If you want to refer just to -a type (in a cast for example) then you leave the name out. But this leads to -strange conflicts due to the parentheses that we introduce to scope the -attributes. Take for example the type of x0 from above. It should be written -as: -

-        int A2 (A1 )[]
-
-But this will lead most C parsers into deep confusion because the parentheses -around A1 will be confused for parentheses of a function designator. To push -this problem around (I don't know a solution) whenever we are about to print a -parenthesized declarator with no name but with attributes, we comment out the -attributes so you can see them (for whatever is worth) without confusing the -compiler. For example, here is how we would print the above type: -

-        int A2 /*(A1 )*/[]
-
- -
Handling of predefined GCC attributes
-GCC already supports attributes in a lot of places in declarations. The only -place where we support attributes and GCC does not is right before the { that -starts a function body.
-
-GCC classifies its attributes in attributes for functions, for variables and -for types, although the latter category is only usable in definition of struct -or union types and is not nearly as powerful as the CIL type attributes. We -have made an effort to reclassify GCC attributes as name and type attributes -(they only apply for function types). Here is what we came up with: -
  • - GCC name attributes:
    -
    -section, constructor, destructor, unused, weak, no_instrument_function, - noreturn, alias, no_check_memory_usage, dllinport, dllexport, exception, - model
    -
    -Note: the "noreturn" attribute would be more appropriately qualified as a - function type attribute. But we classify it as a name attribute to make - it easier to support a similarly named MSVC attribute.
    -
    -
  • GCC function type attributes:
    -
    -fconst (printed as "const"), format, regparm, stdcall, - cdecl, longcall
    -
    -I was not able to completely decipher the position in which these attributes - must go. So, the CIL elaborator knows these names and applies the following - rules: -
    • - All of the name attributes that appear in the specifier part (i.e. at - the beginning) of a declaration are associated with all declared names.
      -
      -
    • All of the name attributes that appear at the end of a declarator are - associated with the particular name being declared.
      -
      -
    • More complicated is the handling of the function type attributes, since - there can be more than one function in a single declaration (a function - returning a pointer to a function). Lacking any real understanding of how - GCC handles this, I attach the function type attribute to the "nearest" - function. This means that if a pointer to a function is "nearby" the - attribute will be correctly associated with the function. In truth I pray - that nobody uses declarations as that of x3 above. -
    -
- -
Handling of predefined MSVC attributes
-MSVC has two kinds of attributes, declaration modifiers to be printed before - the storage specifier using the notation "__declspec(...)" and a few - function type attributes, printed almost as our CIL function type - attributes.
-
-The following are the name attributes that are printed using - __declspec right before the storage designator of the declaration: - thread, naked, dllimport, dllexport, noreturn
-
-The following are the function type attributes supported by MSVC: - fastcall, cdecl, stdcall
-
-It is not worth going into the obscure details of where MSVC accepts these - type attributes. The parser thinks it knows these details and it pulls - these attributes from wherever they might be placed. The important thing - is that MSVC will accept if we print them according to the rules of the CIL - attributes !
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cil007.html b/cil/doc/cil007.html deleted file mode 100644 index 7d6c023..0000000 --- a/cil/doc/cil007.html +++ /dev/null @@ -1,279 +0,0 @@ - - - - - - - - - - - - - -The CIL Driver - - - -Previous -Up -Next -
- -

7  The CIL Driver

-We have packaged CIL as an application cilly that contains certain -example modules, such as logwrites.ml (a module -that instruments code to print the addresses of memory locations being -written). Normally, you write another module like that, add command-line -options and an invocation of your module in src/main.ml. Once you compile -CIL you will obtain the file obj/cilly.asm.exe.
-
-We wrote a driver for this executable that makes it easy to invoke your -analysis on existing C code with very little manual intervention. This driver -is bin/cilly and is quite powerful. Note that the cilly script -is configured during installation with the path where CIL resides. This means -that you can move it to any place you want.
-
-A simple use of the driver is: -
-bin/cilly --save-temps -D HAPPY_MOOD -I myincludes hello.c -o hello
-
---save-temps tells CIL to save the resulting output files in the -current directory. Otherwise, they'll be put in /tmp and deleted -automatically. Not that this is the only CIL-specific flag in the -list – the other flags use gcc's syntax.
-
-This performs the following actions: -
  • -preprocessing using the -D and -I arguments with the resulting - file left in hello.i, -
  • the invocation of the cilly.asm application which parses hello.i - converts it to CIL and the pretty-prints it to hello.cil.c -
  • another round of preprocessing with the result placed in hello.cil.i -
  • the true compilation with the result in hello.cil.o -
  • a linking phase with the result in hello -
-Note that cilly behaves like the gcc compiler. This makes it -easy to use it with existing Makefiles: -
-make CC="bin/cilly" LD="bin/cilly"
-
- cilly can also behave as the Microsoft Visual C compiler, if the first - argument is --mode=MSVC: -
-bin/cilly --mode=MSVC /D HAPPY_MOOD /I myincludes hello.c /Fe hello.exe
-
- (This in turn will pass a --MSVC flag to the underlying cilly.asm - process which will make it understand the Microsoft Visual C extensions)
-
-cilly can also behave as the archiver ar, if it is passed an -argument --mode=AR. Note that only the cr mode is supported (create a -new archive and replace all files in there). Therefore the previous version of -the archive is lost.
-
-Furthermore, cilly allows you to pass some arguments on to the -underlying cilly.asm process. As a general rule all arguments that start -with -- and that cilly itself does not process, are passed on. For -example, -
-bin/cilly --dologwrites -D HAPPY_MOOD -I myincludes hello.c -o hello.exe
-
- will produce a file hello.cil.c that prints all the memory addresses -written by the application.
-
-The most powerful feature of cilly is that it can collect all the -sources in your project, merge them into one file and then apply CIL. This -makes it a breeze to do whole-program analysis and transformation. All you -have to do is to pass the --merge flag to cilly: -
-make CC="bin/cilly --save-temps --dologwrites --merge"
-
- You can even leave some files untouched: -
-make CC="bin/cilly --save-temps --dologwrites --merge --leavealone=foo --leavealone=bar"
-
- This will merge all the files except those with the basename foo and -bar. Those files will be compiled as usual and then linked in at the very -end.
-
-The sequence of actions performed by cilly depends on whether merging -is turned on or not: -
  • -If merging is off -
    1. - For every file file.c to compile -
      1. - Preprocess the file with the given arguments to - produce file.i -
      2. Invoke cilly.asm to produce a file.cil.c -
      3. Preprocess to file.cil.i -
      4. Invoke the underlying compiler to produce file.cil.o -
      -
    2. Link the resulting objects -
    -
  • If merging is on -
    1. - For every file file.c to compile -
      1. - Preprocess the file with the given arguments to - produce file.i -
      2. Save the preprocessed source as file.o -
      -
    2. When linking executable hello.exe, look at every object - file that must be linked and see if it actually - contains preprocessed source. Pass all those files to a - special merging application (described in - Section 13) to produce hello.exe_comb.c -
    3. Invoke cilly.asm to produce a hello.exe_comb.cil.c -
    4. Preprocess to hello.exe_comb.cil.i -
    5. Invoke the underlying compiler to produce hello.exe_comb.cil.o -
    6. Invoke the actual linker to produce hello.exe -
    -
-Note that files that you specify with --leavealone are not merged and -never presented to CIL. They are compiled as usual and then are linked in at -the end.
-
-And a final feature of cilly is that it can substitute copies of the -system's include files: -
-make CC="bin/cilly --includedir=myinclude"
-
- This will force the preprocessor to use the file myinclude/xxx/stdio.h -(if it exists) whenever it encounters #include <stdio.h>. The xxx is -a string that identifies the compiler version you are using. This modified -include files should be produced with the patcher script (see -Section 14).
-
- -

7.1  cilly Options

-Among the options for the cilly you can put anything that can normally -go in the command line of the compiler that cilly is impersonating. -cilly will do its best to pass those options along to the appropriate -subprocess. In addition, the following options are supported (a complete and -up-to-date list can always be obtained by running cilly --help): -
  • ---mode=mode This must be the first argument if present. It makes -cilly behave as a given compiled. The following modes are recognized: -
    • - GNUCC - the GNU C Compiler. This is the default. -
    • MSVC - the Microsoft Visual C compiler. Of course, you should - pass only MSVC valid options in this case. -
    • AR - the archiver ar. Only the mode cr is supported and - the original version of the archive is lost. -
    -
  • --help Prints a list of the options supported. -
  • --verbose Prints lots of messages about what is going on. -
  • --stages Less than --verbose but lets you see what cilly - is doing. -
  • --merge This tells cilly to first attempt to collect into one -source file all of the sources that make your application, and then to apply -cilly.asm on the resulting source. The sequence of actions in this case is -described above and the merger itself is described in Section 13.
    -
    -
  • --leavealone=xxx. Do not merge and do not present to CIL the files -whose basename is "xxx". These files are compiled as usual and linked in at -the end. -
  • --includedir=xxx. Override the include files with those in the given -directory. The given directory is the same name that was given an an argument -to the patcher (see Section 14). In particular this means that -that directory contains subdirectories named based on the current compiler -version. The patcher creates those directories. -
  • --usecabs. Do not CIL, but instead just parse the source and print -its AST out. This should looked like the preprocessed file. This is useful -when you suspect that the conversion to CIL phase changes the meaning of the -program. -
  • --save-temps=xxx. Temporary files are preserved in the xxx - directory. For example, the output of CIL will be put in a file - named *.cil.c. -
  • --save-temps. Temporay files are preserved in the current directory. -
- -

7.2  cilly.asm Options

- -All of the options that start with -- and are not understood by -cilly are passed on to cilly.asm. cilly also passes along to -cilly.asm flags such as --MSVC that both need to know -about. The following options are supported:
-
-       General Options: -
  • - --version output version information and exit -
  • --verbose Print lots of random stuff. This is passed on from cilly -
  • --warnall Show all warnings. -
  • --debug=xxx turns on debugging flag xxx -
  • --nodebug=xxx turns off debugging flag xxx -
  • --flush Flush the output streams often (aids debugging). -
  • --check Run a consistency check over the CIL after every operation. -
  • --nocheck turns off consistency checking of CIL. -
  • --noPrintLn Don't output #line directives in the output. -
  • --commPrintLn Print #line directives in the output, but - put them in comments. -
  • --log=xxx Set the name of the log file. By default stderr is used -
  • --MSVC Enable MSVC compatibility. Default is GNU. -
  • --ignore-merge-conflicts ignore merging conflicts. -
  • --extrafiles=filename: the name of a file that contains - a list of additional files to process, separated by whitespace. -
  • --stats Print statistics about the running time of the - parser, conversion to CIL, etc. Also prints memory-usage - statistics. You can time parts of your own code as well. Calling - (Stats.time “label” func arg) will evaluate (func arg) - and remember how long this takes. If you call Stats.time - repeatedly with the same label, CIL will report the aggregate - time.
    -
    -If available, CIL uses the x86 performance counters for these - stats. This is very precise, but results in “wall-clock time.” - To report only user-mode time, find the call to Stats.reset in - main.ml, and change it to Stats.reset false.
    -
    -Lowering Options -
  • --noLowerConstants do not lower constant expressions. -
  • --noInsertImplicitCasts do not insert implicit casts. -
  • --forceRLArgEval Forces right to left evaluation of function arguments. -
  • --disallowDuplication Prevent small chunks of code from being duplicated. -
  • --keepunused Do not remove the unused variables and types. -
  • --rmUnusedInlines Delete any unused inline functions. This is the default in MSVC mode.
    -
    -Output Options: -
  • --printCilAsIs Do not try to simplify the CIL when - printing. Without this flag, CIL will attempt to produce prettier - output by e.g. changing while(1) into more meaningful loops. -
  • --noWrap do not wrap long lines when printing -
  • --out=xxx the name of the output CIL file. cilly - sets this for you. -
  • --mergedout=xxx specify the name of the merged file -
  • --cabsonly=xxx CABS output file name -
    -
    - Selected features. See Section 8 for more information. -
  • --dologcalls. Insert code in the processed source to print the name of -functions as are called. Implemented in src/ext/logcalls.ml. -
  • --dologwrites. Insert code in the processed source to print the -address of all memory writes. Implemented in src/ext/logwrites.ml. -
  • --dooneRet. Make each function have at most one 'return'. -Implemented in src/ext/oneret.ml. -
  • --dostackGuard. Instrument function calls and returns to -maintain a separate stack for return addresses. Implemeted in -src/ext/heapify.ml. -
  • --domakeCFG. Make the program look more like a CFG. Implemented -in src/cil.ml. -
  • --dopartial. Do interprocedural partial evaluation and -constant folding. Implemented in src/ext/partial.ml. -
  • --dosimpleMem. Simplify all memory expressions. Implemented in -src/ext/simplemem.ml.
    -
    -For an up-to-date list of available options, run cilly.asm --help.
-
-Previous -Up -Next - - diff --git a/cil/doc/cil009.html b/cil/doc/cil009.html deleted file mode 100644 index f408d00..0000000 --- a/cil/doc/cil009.html +++ /dev/null @@ -1,48 +0,0 @@ - - - - - - - - - - - - - -Controlling CIL - - - -Previous -Up -Next -
- -

9  Controlling CIL

-In the process of converting a C file to CIL we drop the unused prototypes -and even inline function definitions. This results in much smaller files. If -you do not want this behavior then you must pass the --keepunused argument -to the CIL application.
-
-Alternatively you can put the following pragma in the code (instructing CIL -to specifically keep the declarations and definitions of the function -func1 and variable var2, the definition of type foo and of -structure bar): -

-#pragma cilnoremove("func1", "var2", "type foo", "struct bar")
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cil010.html b/cil/doc/cil010.html deleted file mode 100644 index e7b1e4b..0000000 --- a/cil/doc/cil010.html +++ /dev/null @@ -1,100 +0,0 @@ - - - - - - - - - - - - - -GCC Extensions - - - -Previous -Up -Next -
- -

10  GCC Extensions

-The CIL parser handles most of the gcc -extensions -and compiles them to CIL. The following extensions are not handled (note that -we are able to compile a large number of programs, including the Linux kernel, -without encountering these): -
  1. -Nested function definitions. -
  2. Constructing function calls. -
  3. Naming an expression's type. -
  4. Complex numbers -
  5. Hex floats -
  6. Subscripts on non-lvalue arrays. -
  7. Forward function parameter declarations -
-The following extensions are handled, typically by compiling them away: -
  1. -Attributes for functions, variables and types. In fact, we have a clear -specification (see Section 6.4) of how attributes are interpreted. The -specification extends that of gcc. -
  2. Old-style function definitions and prototypes. These are translated to -new-style. -
  3. Locally-declared labels. As part of the translation to CIL, we generate -new labels as needed. -
  4. Labels as values and computed goto. This allows a program to take the -address of a label and to manipulate it as any value and also to perform a -computed goto. We compile this by assigning each label whose address is taken -a small integer that acts as its address. Every computed goto in the body -of the function is replaced with a switch statement. If you want to invoke -the label from another function, you are on your own (the gcc -documentation says the same.) -
  5. Generalized lvalues. You can write code like (a, b) += 5 and it gets -translated to CIL. -
  6. Conditionals with omitted operands. Things like x ? : y are -translated to CIL. -
  7. Double word integers. The type long long and the LL suffix on -constants is understood. This is currently interpreted as 64-bit integers. -
  8. Local arrays of variable length. These are converted to uses of -alloca, the array variable is replaced with a pointer to the allocated -array and the instances of sizeof(a) are adjusted to return the size of -the array and not the size of the pointer. -
  9. Non-constant local initializers. Like all local initializers these are -compiled into assignments. -
  10. Compound literals. These are also turned into assignments. -
  11. Designated initializers. The CIL parser actually supports the full ISO -syntax for initializers, which is more than both gcc and MSVC. I -(George) think that this is the most complicated part of the C language and -whoever designed it should be banned from ever designing languages again. -
  12. Case ranges. These are compiled into separate cases. There is no code -duplication, just a larger number of case statements. -
  13. Transparent unions. This is a strange feature that allows you to define -a function whose formal argument has a (tranparent) union type, but the -argument is called as if it were the first element of the union. This is -compiled away by saying that the type of the formal argument is that of the -first field, and the first thing in the function body we copy the formal into -a union.
    -
    -
  14. Inline assembly-language. The full syntax is supported and it is carried -as such in CIL.
    -
    -
  15. Function names as strings. The identifiers __FUNCTION__ and -__PRETTY_FUNCTION__ are replaced with string literals.
    -
    -
  16. Keywords typeof, alignof, inline are supported. -
-
-Previous -Up -Next - - diff --git a/cil/doc/cil011.html b/cil/doc/cil011.html deleted file mode 100644 index 975c8dd..0000000 --- a/cil/doc/cil011.html +++ /dev/null @@ -1,53 +0,0 @@ - - - - - - - - - - - - - -CIL Limitations - - - -Previous -Up -Next -
- -

11  CIL Limitations

-There are several implementation details of CIL that might make it unusable - or less than ideal for certain tasks: -
  • -CIL operates after preprocessing. If you need to see comments, for -example, you cannot use CIL. But you can use attributes and pragmas instead. -And there is some support to help you patch the include files before they are -seen by the preprocessor. For example, this is how we turn some -#defines that we don't like into function calls.
    -
    -
  • CIL does transform the code in a non-trivial way. This is done in order -to make most analyses easier. But if you want to see the code e1, e2++ -exactly as it appears in the code, then you should not use CIL.
    -
    -
  • CIL removes all local scopes and moves all variables to function -scope. It also separates a declaration with an initializer into a declaration -plus an assignment. The unfortunate effect of this transformation is that -local variables cannot have the const qualifier.
-
-Previous -Up -Next - - diff --git a/cil/doc/cil012.html b/cil/doc/cil012.html deleted file mode 100644 index 5d18fd5..0000000 --- a/cil/doc/cil012.html +++ /dev/null @@ -1,133 +0,0 @@ - - - - - - - - - - - - - -Known Bugs and Limitations - - - -Previous -Up -Next -
- -

12  Known Bugs and Limitations

-
  • In the new versions of glibc there is a function - __builtin_va_arg that takes a type as its second argument. CIL - handles that through a slight trick. As it parses the function it changes a - call like: -
    -  mytype x = __builtin_va_arg(marker, mytype)
-
    into -
    - mytype x;
- __builtin_va_arg(marker, sizeof(mytype), &x);
-
    - The latter form is used internally in CIL. However, the CIL pretty printer - will try to emit the original code.
    -
    -Similarly, __builtin_types_compatible_p(t1, t2), which takes - types as arguments, is represented internally as - __builtin_types_compatible_p(sizeof t1, sizeof t2), but the - sizeofs are removed when printing.
    -
    -
  • The implementation of bitsSizeOf does not take into account the -packing pragmas. However it was tested to be accurate on cygwin/gcc-2.95.3, -Linux/gcc-2.95.3 and on Windows/MSVC.
    -
    -
  • We do not support tri-graph sequences (ISO 5.2.1.1).
    -
    -
  • GCC has a strange feature called “extern inline”. Such a function can -be defined twice: first with the “extern inline” specifier and the second -time without it. If optimizations are turned off then the “extern inline” -definition is considered a prototype (its body is ignored). If optimizations -are turned on then the extern inline function is inlined at all of its -occurrences from the point of its definition all the way to the point where the -(optional) second definition appears. No body is generated for an extern -inline function. A body is generated for the real definition and that one is -used in the rest of the file.
    -
    -CIL will rename your extern inline function (and its uses) with the suffix - __extinline. This means that if you have two such definition, that do - different things and the optimizations are not on, then the CIL version might - compute a different answer !
    -
    -Also, if you have multiple extern inline declarations then CIL will ignore -but the first one. This is not so bad because GCC itself would not like it.
    -
    -
  • There are still a number of bugs in handling some obscure features of -GCC. For example, when you use variable-length arrays, CIL turns them into -calls to alloca. This means that they are deallocated when the function -returns and not when the local scope ends.
    -
    -Variable-length arrays are not supported as fields of a struct or union.
    -
    -
  • CIL cannot parse arbitrary #pragma directives. Their - syntax must follow gcc's attribute syntax to be understood. If you - need a pragma that does not follow gcc syntax, add that pragma's name - to no_parse_pragma in src/frontc/clexer.mll to indicate that - CIL should treat that pragma as a monolithic string rather than try - to parse its arguments.
    -
    -CIL cannot parse a line containing an empty #pragma.
    -
    -
  • CIL only parses #pragma directives at the "top level", this is, - outside of any enum, structure, union, or function definitions.
    -
    -If your compiler uses pragmas in places other than the top-level, - you may have to preprocess the sources in a special way (sed, perl, - etc.) to remove pragmas from these locations.
    -
    -
  • CIL cannot parse the following code (fixing this problem would require -extensive hacking of the LALR grammar): -
    
-int bar(int ()); // This prototype cannot be parsed
-int bar(int x()); // If you add a name to the function, it works
-int bar(int (*)()); // This also works (and it is more appropriate)
-

    -
    -
  • CIL also cannot parse certain K&R old-style prototypes with missing -return type: -
    
-g(); // This cannot be parsed
-int g(); // This is Ok
-

    -
    -
  • CIL does not understand some obscure combinations of type specifiers -(“signed” and “unsigned” applied to typedefs that themselves contain a -sign specification; you could argue that this should not be allowed anyway): -
    
-typedef signed char __s8;
-__s8 unsigned uchartest; // This is unsigned char for gcc
-

    -
    -
  • The statement x = 3 + x ++ will perform the increment of x - before the assignment, while gcc delays the increment after the - assignment. It turned out that this behavior is much easier to implement - than gcc's one, and either way is correct (since the behavior is unspecified - in this case). Similarly, if you write x = x ++; then CIL will perform - the increment before the assignment, whereas GCC and MSVC will perform it - after the assignment. -
-
-Previous -Up -Next - - diff --git a/cil/doc/cil015.html b/cil/doc/cil015.html deleted file mode 100644 index a3dff7d..0000000 --- a/cil/doc/cil015.html +++ /dev/null @@ -1,60 +0,0 @@ - - - - - - - - - - - - - -Debugging support - - - -Previous -Up -Next -
- -

15  Debugging support

-Most of the time we debug our code using the Errormsg module along with the -pretty printer. But if you want to use the Ocaml debugger here is an easy way -to do it. Say that you want to debug the invocation of cilly that arises out -of the following command: -
-cilly -c hello.c 
-
- You must follow the installation instructions -to install the Elist support files for ocaml and to extend your .emacs -appropriately. Then from within Emacs you do -
-ALT-X my-camldebug
-
- This will ask you for the command to use for running the Ocaml debugger -(initially the default will be “ocamldebug” or the last command you -introduced). You use the following command: -
-cilly --ocamldebug -c hello.c 
-
- This will run cilly as usual and invoke the Ocaml debugger when the cilly -engine starts. The advantage of this way of invoking the debugger is that the -directory search paths are set automatically and the right set or arguments is -passed to the debugger.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cil016.html b/cil/doc/cil016.html deleted file mode 100644 index 3191a9d..0000000 --- a/cil/doc/cil016.html +++ /dev/null @@ -1,342 +0,0 @@ - - - - - - - - - - - - - -Who Says C is Simple? - - - -Previous -Up -Next -
- -

16  Who Says C is Simple?

-When I (George) started to write CIL I thought it was going to take two weeks. -Exactly a year has passed since then and I am still fixing bugs in it. This -gross underestimate was due to the fact that I thought parsing and making -sense of C is simple. You probably think the same. What I did not expect was -how many dark corners this language has, especially if you want to parse -real-world programs such as those written for GCC or if you are more ambitious -and you want to parse the Linux or Windows NT sources (both of these were -written without any respect for the standard and with the expectation that -compilers will be changed to accommodate the program).
-
-The following examples were actually encountered either in real programs or -are taken from the ISO C99 standard or from the GCC's testcases. My first -reaction when I saw these was: Is this C?. The second one was : What the hell does it mean?.
-
-If you are contemplating doing program analysis for C on abstract-syntax -trees then your analysis ought to be able to handle these things. Or, you can -use CIL and let CIL translate them into clean C code.
-
- -

16.1  Standard C

-
  1. Why does the following code return 0 for most values of x? (This -should be easy.) -
    
-  int x;
-  return x == (1 && x);
-
    -See the CIL output for this -code fragment
    -
    -
  2. Why does the following code return 0 and not -1? (Answer: because -sizeof is unsigned, thus the result of the subtraction is unsigned, thus -the shift is logical.) -
    
- return ((1 - sizeof(int)) >> 32);
-
    -See the CIL output for this -code fragment
    -
    -
  3. Scoping rules can be tricky. This function returns 5. -
    
-int x = 5;
-int f() {
-  int x = 3;
-  {
-    extern int x;
-    return x;
-  }
-}
-
    -See the CIL output for this -code fragment
    -
    -
  4. Functions and function pointers are implicitly converted to each other. -
    
-int (*pf)(void);
-int f(void) {
-
-   pf = &f; // This looks ok
-   pf = ***f; // Dereference a function?
-   pf(); // Invoke a function pointer?     
-   (****pf)();  // Looks strange but Ok
-   (***************f)(); // Also Ok             
-}
-
    -See the CIL output for this -code fragment
    -
    -
  5. Initializer with designators are one of the hardest parts about ISO C. -Neither MSVC or GCC implement them fully. GCC comes close though. What is the -final value of i.nested.y and i.nested.z? (Answer: 2 and respectively -6). -
    
-struct { 
-   int x; 
-   struct { 
-       int y, z; 
-   } nested;
-} i = { .nested.y = 5, 6, .x = 1, 2 };               
-
    -See the CIL output for this -code fragment
    -
    -
  6. This is from c-torture. This function returns 1. -
    
-typedef struct
-{
-  char *key;
-  char *value;
-} T1;
-
-typedef struct
-{
-  long type;
-  char *value;
-} T3;
-
-T1 a[] =
-{
-  {
-    "",
-    ((char *)&((T3) {1, (char *) 1}))
-  }
-};
-int main() {
-   T3 *pt3 = (T3*)a[0].value;
-   return pt3->value;
-}
-
    -See the CIL output for this -code fragment
    -
    -
  7. Another one with constructed literals. This one is legal according to -the GCC documentation but somehow GCC chokes on (it works in CIL though). This -code returns 2. -
    
- return ((int []){1,2,3,4})[1];
-
    -See the CIL output for this -code fragment
    -
    -
  8. In the example below there is one copy of “bar” and two copies of - “pbar” (static prototypes at block scope have file scope, while for all - other types they have block scope). -
    
-  int foo() {
-     static bar();
-     static (*pbar)() = bar;
-
-  }
-
-  static bar() { 
-    return 1;
-  }
-
-  static (*pbar)() = 0;
-
    -See the CIL output for this -code fragment
    -
    -
  9. Two years after heavy use of CIL, by us and others, I discovered a bug - in the parser. The return value of the following function depends on what - precedence you give to casts and unary minus: -
    
-  unsigned long foo() {
-    return (unsigned long) - 1 / 8;
-  }
-
    -See the CIL output for this -code fragment
    -
    -The correct interpretation is ((unsigned long) - 1) / 8, which is a - relatively large number, as opposed to (unsigned long) (- 1 / 8), which - is 0.
- -

16.2  GCC ugliness

-
  1. GCC has generalized lvalues. You can take the address of a lot of -strange things: -
    
-  int x, y, z;
-  return &(x ? y : z) - & (x++, x);
-
    -See the CIL output for this -code fragment
    -
    -
  2. GCC lets you omit the second component of a conditional expression. -
    
-  extern int f();
-  return f() ? : -1; // Returns the result of f unless it is 0
-
    -See the CIL output for this -code fragment
    -
    -
  3. Computed jumps can be tricky. CIL compiles them away in a fairly clean -way but you are on your own if you try to jump into another function this way. -
    
-static void *jtab[2]; // A jump table
-static int doit(int x){
- 
-  static int jtab_init = 0;
-  if(!jtab_init) { // Initialize the jump table
-    jtab[0] = &&lbl1;
-    jtab[1] = &&lbl2;
-    jtab_init = 1;
-  }
-  goto *jtab[x]; // Jump through the table
-lbl1:
-  return 0;
-lbl2:
-  return 1;
-}
- 
-int main(void){
-  if (doit(0) != 0) exit(1);
-  if (doit(1) != 1) exit(1);
-  exit(0);
-}
-
    -See the CIL output for this -code fragment
    -
    -
  4. A cute little example that we made up. What is the returned value? -(Answer: 1); -
    
- return ({goto L; 0;}) && ({L: 5;});
-
    -See the CIL output for this -code fragment
    -
    -
  5. extern inline is a strange feature of GNU C. Can you guess what the -following code computes? -
    
-extern inline foo(void) { return 1; }
-int firstuse(void) { return foo(); }
-
-// A second, incompatible definition of foo
-int foo(void) { return 2; }
-
-int main() {
-    return foo() + firstuse();
-}
-
    -See the CIL output for this -code fragment
    -
    -The answer depends on whether the optimizations are turned on. If they are -then the answer is 3 (the first definition is inlined at all occurrences until -the second definition). If the optimizations are off, then the first -definition is ignore (treated like a prototype) and the answer is 4.
    -
    -CIL will misbehave on this example, if the optimizations are turned off (it - always returns 3).
    -
    -
  6. GCC allows you to cast an object of a type T into a union as long as the -union has a field of that type: -
    
-union u { 
-   int i; 
-   struct s { 
-      int i1, i2;
-   } s;
-};
-
-union u x = (union u)6;
-
-int main() {
-  struct s y = {1, 2};
-  union u  z = (union u)y;
-}
-
    -See the CIL output for this -code fragment
    -
    -
  7. GCC allows you to use the __mode__ attribute to specify the size -of the integer instead of the standard char, short and so on: -
    
-int __attribute__ ((__mode__ (  __QI__ ))) i8;
-int __attribute__ ((__mode__ (  __HI__ ))) i16;
-int __attribute__ ((__mode__ (  __SI__ ))) i32;
-int __attribute__ ((__mode__ (  __DI__ ))) i64;
-
    -See the CIL output for this -code fragment
    -
    -
  8. The “alias” attribute on a function declaration tells the - linker to treat this declaration as another name for the specified - function. CIL will replace the declaration with a trampoline - function pointing to the specified target. -
    
-    static int bar(int x, char y) {
-      return x + y;
-    }
-
-    //foo is considered another name for bar.
-    int foo(int x, char y) __attribute__((alias("bar")));
-
    -See the CIL output for this -code fragment
- -

16.3  Microsoft VC ugliness

-This compiler has few extensions, so there is not much to say here. -
  1. -Why does the following code return 0 and not -1? (Answer: because of a -bug in Microsoft Visual C. It thinks that the shift is unsigned just because -the second operator is unsigned. CIL reproduces this bug when in MSVC mode.) -
    
- return -3 >> (8 * sizeof(int));
-

    -
    -
  2. Unnamed fields in a structure seem really strange at first. It seems -that Microsoft Visual C introduced this extension, then GCC picked it up (but -in the process implemented it wrongly: in GCC the field y overlaps with -x!). -
    
-struct {
-  int x;
-  struct {
-     int y, z;
-     struct {
-       int u, v;
-     };
- };
-} a;
-return a.x + a.y + a.z + a.u + a.v;
-
    -See the CIL output for this -code fragment
-
-Previous -Up -Next - - diff --git a/cil/doc/cil017.html b/cil/doc/cil017.html deleted file mode 100644 index a9e04eb..0000000 --- a/cil/doc/cil017.html +++ /dev/null @@ -1,53 +0,0 @@ - - - - - - - - - - - - - -Authors - - - -Previous -Up -Next -
- -

17  Authors

-The CIL parser was developed starting from Hugues Casse's frontc -front-end for C although all the files from the frontc distribution have -been changed very extensively. The intermediate language and the elaboration -stage are all written from scratch. The main author is -George Necula, with significant -contributions from Scott McPeak, -Westley Weimer, -Ben Liblit, -Matt Harren, -Raymond To and Aman Bhargava.
-
-This work is based upon work supported in part by the National Science -Foundation under Grants No. 9875171, 0085949 and 0081588, and gifts from -Microsoft Research. Any opinions, findings, and conclusions or recommendations -expressed in this material are those of the author(s) and do not necessarily -reflect the views of the National Science Foundation or the other sponsors.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cil018.html b/cil/doc/cil018.html deleted file mode 100644 index dc039ea..0000000 --- a/cil/doc/cil018.html +++ /dev/null @@ -1,71 +0,0 @@ - - - - - - - - - - - - - -License - - - -Previous -Up -Next -
- -

18  License

-Copyright (c) 2001-2005, -
  • -George C. Necula <necula@cs.berkeley.edu> -
  • Scott McPeak <smcpeak@cs.berkeley.edu> -
  • Wes Weimer <weimer@cs.berkeley.edu> -
  • Ben Liblit <liblit@cs.wisc.edu> -
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met:
-
-1. Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer.
-
-2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution.
-
-3. The names of the contributors may not be used to endorse or promote -products derived from this software without specific prior written -permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cil019.html b/cil/doc/cil019.html deleted file mode 100644 index 84e3f8b..0000000 --- a/cil/doc/cil019.html +++ /dev/null @@ -1,45 +0,0 @@ - - - - - - - - - - - - - -Bug reports - - - -Previous -Up -Next -
- -

19  Bug reports

-We are certain that there are still some remaining bugs in CIL. If you find -one please file a bug report in our Source Forge space -http://sourceforge.net/projects/cil.
-
-You can find there the latest announcements, a source distribution, -bug report submission instructions and a mailing list: cil-users[at -sign]lists.sourceforge.net. Please use this list to ask questions about CIL, -as it will ensure your message is viewed by a broad audience.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cilly.html b/cil/doc/cilly.html deleted file mode 100644 index 1a28758..0000000 --- a/cil/doc/cilly.html +++ /dev/null @@ -1,187 +0,0 @@ - - - - - - - - - - - - - -How to Use CIL - - - -Previous -Up -Next -
- -

5  How to Use CIL


-
-There are two predominant ways to use CIL to write a program analysis or -transformation. The first is to phrase your analysis as a module that is -called by our existing driver. The second is to use CIL as a stand-alone -library. We highly recommend that you use cilly, our driver.
-
- -

5.1  Using cilly, the CIL driver

-The most common way to use CIL is to write an Ocaml module containing your -analysis and transformation, which you then link into our boilerplate -driver application called cilly. cilly is a Perl script that -processes and mimics GCC and MSVC command-line arguments and then -calls cilly.byte.exe or cilly.asm.exe (CIL's Ocaml executable).
-
-An example of such module is logwrites.ml, a transformation that is -distributed with CIL and whose purpose is to instrument code to print the -addresses of memory locations being written. (We plan to release a -C-language interface to CIL so that you can write your analyses in C -instead of Ocaml.) See Section 8 for a survey of other example -modules.
-
-Assuming that you have written /home/necula/logwrites.ml, -here is how you use it: -
  1. Modify logwrites.ml so that it includes a CIL “feature - descriptor” like this: -
    -let feature : featureDescr = 
-  { fd_name = "logwrites";              
-    fd_enabled = ref false;
-    fd_description = "generation of code to log memory writes";
-    fd_extraopt = [];
-    fd_doit = 
-    (function (f: file) -> 
-      let lwVisitor = new logWriteVisitor in
-      visitCilFileSameGlobals lwVisitor f)
-  } 
-
    The fd_name field names the feature and its associated - command-line arguments. The fd_enabled field is a bool ref. - “fd_doit” will be invoked if !fd_enabled is true after - argument parsing, so initialize the ref cell to true if you want - this feature to be enabled by default.
    -
    -When the user passes the --dologwrites - command-line option to cilly, the variable associated with the - fd_enabled flag is set and the fd_doit function is called - on the Cil.file that represents the merger (see Section 13) of - all C files listed as arguments.
    -
    -
  2. Invoke configure with the arguments -
    -./configure EXTRASRCDIRS=/home/necula EXTRAFEATURES=logwrites
-
    - This step works if each feature is packaged into its own ML file, and the -name of the entry point in the file is feature.
    -
    -An alternative way to specify the new features is to change the build files -yourself, as explained below. You'll need to use this method if a single -feature is split across multiple files. -
    1. - Put logwrites.ml in the src or src/ext directory. This - will make sure that make can find it. If you want to put it in some - other directory, modify Makefile.in and add to SOURCEDIRS your - directory. Alternately, you can create a symlink from src or - src/ext to your file.
      -
      -
    2. Modify the Makefile.in and add your module to the - CILLY_MODULES or - CILLY_LIBRARY_MODULES variables. The order of the modules matters. Add - your modules somewhere after cil and before main.
      -
      -
    3. If you have any helper files for your module, add those to - the makefile in the same way. e.g.: -
      -CILLY_MODULES = $(CILLY_LIBRARY_MODULES) \
-                myutilities1 myutilities2 logwrites \
-                main
-
      - Again, order is important: myutilities2.ml will be able to refer - to Myutilities1 but not Logwrites. If you have any ocamllex or ocamlyacc - files, add them to both CILLY_MODULES and either MLLS or - MLYS.
      -
      -
    4. Modify main.ml so that your new feature descriptor appears in - the global list of CIL features. -
      -let features : C.featureDescr list = 
-  [ Logcalls.feature;
-    Oneret.feature;    
-    Heapify.feature1;  
-    Heapify.feature2;
-    makeCFGFeature; 
-    Partial.feature;
-    Simplemem.feature;
-    Logwrites.feature;  (* add this line to include the logwrites feature! *)
-  ] 
-  @ Feature_config.features 
-
      - Features are processed in the order they appear on this list. Put - your feature last on the list if you plan to run any of CIL's - built-in features (such as makeCFGfeature) before your own.

    -Standard code in cilly takes care of adding command-line arguments, - printing the description, and calling your function automatically. - Note: do not worry about introducing new bugs into CIL by adding a single - line to the feature list.
    -
    -
  3. Now you can invoke the cilly application on a preprocessed file, or - instead use the cilly driver which provides a convenient compiler-like - interface to cilly. See Section 7 for details using cilly. - Remember to enable your analysis by passing the right argument (e.g., - --dologwrites).
- -

5.2  Using CIL as a library

-CIL can also be built as a library that is called from your stand-alone -application. Add cil/src, cil/src/frontc, cil/obj/x86_LINUX -(or cil/obj/x86_WIN32) to your Ocaml project -I include paths. -Building CIL will also build the library cil/obj/*/cil.cma (or -cil/obj/*/cil.cmxa). You can then link your application against that -library.
-
-You can call the Frontc.parse: string -> unit -> Cil.file function with -the name of a file containing the output of the C preprocessor. -The Mergecil.merge: Cil.file list -> string -> Cil.file function merges -multiple files. You can then invoke your analysis function on the resulting -Cil.file data structure. You might want to call -Rmtmps.removeUnusedTemps first to clean up the prototypes and variables -that are not used. Then you can call the function Cil.dumpFile: -cilPrinter -> out_channel -> Cil.file -> unit to print the file to a -given output channel. A good cilPrinter to use is -defaultCilPrinter.
-
-Check out src/main.ml and bin/cilly for other good ideas -about high-level file processing. Again, we highly recommend that you just -our cilly driver so that you can avoid spending time re-inventing the -wheel to provide drop-in support for standard makefiles.
-
-Here is a concrete example of compiling and linking your project against -CIL. Imagine that your program analysis or transformation is contained in -the single file main.ml. -
-$ ocamlopt -c -I $(CIL)/obj/x86_LINUX/ main.ml
-$ ocamlopt -ccopt -L$(CIL)/obj/x86_LINUX/ -o main unix.cmxa str.cmxa \ 
-        $(CIL)/obj/x86_LINUX/cil.cmxa main.cmx
-
-The first line compiles your analysis, the second line links it against CIL -(as a library) and the Ocaml Unix library. For more information about -compiling and linking Ocaml programs, see the Ocaml home page -at http://caml.inria.fr/ocaml/.
-
-In the next section we give an overview of the API that you can use -to write your analysis and transformation.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/cilpp.haux b/cil/doc/cilpp.haux deleted file mode 100644 index 1b9fa16..0000000 --- a/cil/doc/cilpp.haux +++ /dev/null @@ -1,64 +0,0 @@ -\@addtocsec{htoc}{1}{0}{\@print{1}\quad{}Introduction} -\@addtocsec{htoc}{2}{0}{\@print{2}\quad{}Installation} -\@addtocsec{htoc}{3}{0}{\@print{3}\quad{}Distribution Contents} -\@addtocsec{htoc}{4}{0}{\@print{4}\quad{}Compiling C to CIL} -\newlabel{sec-cabs2cil}{{4}{X}} -\@addtocsec{htoc}{5}{0}{\@print{5}\quad{}How to Use CIL} -\newlabel{sec-cil}{{5}{X}} -\@addtocsec{htoc}{6}{1}{\@print{5.1}\quad{}Using \t{cilly}, the CIL driver} -\@addtocsec{htoc}{7}{1}{\@print{5.2}\quad{}Using CIL as a library} -\@addtocsec{htoc}{8}{0}{\@print{6}\quad{}CIL API Documentation} -\newlabel{sec-api}{{6}{X}} -\@addtocsec{htoc}{9}{1}{\@print{6.1}\quad{}Using the visitor} -\newlabel{sec-visitor}{{6.1}{X}} -\@addtocsec{htoc}{10}{1}{\@print{6.2}\quad{}Interpreted Constructors and Deconstructors} -\@addtocsec{htoc}{11}{2}{\@print{6.2.1}\quad{}Performance considerations for interpreted constructors} -\@addtocsec{htoc}{12}{1}{\@print{6.3}\quad{}Printing and Debugging support} -\@addtocsec{htoc}{13}{1}{\@print{6.4}\quad{}Attributes} -\newlabel{sec-attrib}{{6.4}{X}} -\@addtocsec{htoc}{14}{0}{\@print{7}\quad{}The CIL Driver} -\newlabel{sec-driver}{{7}{X}} -\@addtocsec{htoc}{15}{1}{\@print{7.1}\quad{}\t{cilly} Options} -\@addtocsec{htoc}{16}{1}{\@print{7.2}\quad{}\t{cilly.asm} Options} -\newlabel{sec-cilly-asm-options}{{7.2}{X}} -\@addtocsec{htoc}{17}{0}{\@print{8}\quad{}Library of CIL Modules} -\newlabel{sec-Extension}{{8}{X}} -\@addtocsec{htoc}{18}{1}{\@print{8.1}\quad{}Control-Flow Graphs} -\newlabel{sec-cfg}{{8.1}{X}} -\@addtocsec{htoc}{19}{2}{\@print{8.1.1}\quad{}The CFG module (new in CIL 1.3.5)} -\@addtocsec{htoc}{20}{2}{\@print{8.1.2}\quad{}Simplified control flow} -\@addtocsec{htoc}{21}{1}{\@print{8.2}\quad{}Data flow analysis framework} -\@addtocsec{htoc}{22}{1}{\@print{8.3}\quad{}Dominators} -\@addtocsec{htoc}{23}{1}{\@print{8.4}\quad{}Points-to Analysis} -\@addtocsec{htoc}{24}{1}{\@print{8.5}\quad{}StackGuard} -\@addtocsec{htoc}{25}{1}{\@print{8.6}\quad{}Heapify} -\@addtocsec{htoc}{26}{1}{\@print{8.7}\quad{}One Return} -\@addtocsec{htoc}{27}{1}{\@print{8.8}\quad{}Partial Evaluation and Constant Folding} -\@addtocsec{htoc}{28}{1}{\@print{8.9}\quad{}Reaching Definitions} -\@addtocsec{htoc}{29}{1}{\@print{8.10}\quad{}Available Expressions} -\@addtocsec{htoc}{30}{1}{\@print{8.11}\quad{}Liveness Analysis} -\@addtocsec{htoc}{31}{1}{\@print{8.12}\quad{}Dead Code Elimination} -\@addtocsec{htoc}{32}{1}{\@print{8.13}\quad{}Simple Memory Operations} -\@addtocsec{htoc}{33}{1}{\@print{8.14}\quad{}Simple Three-Address Code} -\@addtocsec{htoc}{34}{1}{\@print{8.15}\quad{}Converting C to C++} -\@addtocsec{htoc}{35}{0}{\@print{9}\quad{}Controlling CIL} -\@addtocsec{htoc}{36}{0}{\@print{10}\quad{}GCC Extensions} -\@addtocsec{htoc}{37}{0}{\@print{11}\quad{}CIL Limitations} -\@addtocsec{htoc}{38}{0}{\@print{12}\quad{}Known Bugs and Limitations} -\@addtocsec{htoc}{39}{0}{\@print{13}\quad{}Using the merger} -\newlabel{sec-merger}{{13}{X}} -\@addtocsec{htoc}{40}{0}{\@print{14}\quad{}Using the patcher} -\newlabel{sec-patcher}{{14}{X}} -\@addtocsec{htoc}{41}{0}{\@print{15}\quad{}Debugging support} -\newlabel{sec-debugger}{{15}{X}} -\@addtocsec{htoc}{42}{0}{\@print{16}\quad{}Who Says C is Simple?} -\newlabel{sec-simplec}{{16}{X}} -\@addtocsec{htoc}{43}{1}{\@print{16.1}\quad{}Standard C} -\@addtocsec{htoc}{44}{1}{\@print{16.2}\quad{}GCC ugliness} -\newlabel{sec-ugly-gcc}{{16.2}{X}} -\@addtocsec{htoc}{45}{1}{\@print{16.3}\quad{}Microsoft VC ugliness} -\@addtocsec{htoc}{46}{0}{\@print{17}\quad{}Authors} -\@addtocsec{htoc}{47}{0}{\@print{18}\quad{}License} -\@addtocsec{htoc}{48}{0}{\@print{19}\quad{}Bug reports} -\@addtocsec{htoc}{49}{0}{\@print{20}\quad{}Changes} -\newlabel{sec-changes}{{20}{X}} diff --git a/cil/doc/cilpp.htoc b/cil/doc/cilpp.htoc deleted file mode 100644 index d5bc0e5..0000000 --- a/cil/doc/cilpp.htoc +++ /dev/null @@ -1,65 +0,0 @@ -\begin{tocenv} -\tocitem \@locref{htoc1}{\begin{@norefs}\@print{1}\quad{}Introduction\end{@norefs}} -\tocitem \@locref{htoc2}{\begin{@norefs}\@print{2}\quad{}Installation\end{@norefs}} -\tocitem \@locref{htoc3}{\begin{@norefs}\@print{3}\quad{}Distribution Contents\end{@norefs}} -\tocitem \@locref{htoc4}{\begin{@norefs}\@print{4}\quad{}Compiling C to CIL\end{@norefs}} -\tocitem \@locref{htoc5}{\begin{@norefs}\@print{5}\quad{}How to Use CIL\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc6}{\begin{@norefs}\@print{5.1}\quad{}Using \t{cilly}, the CIL driver\end{@norefs}} -\tocitem \@locref{htoc7}{\begin{@norefs}\@print{5.2}\quad{}Using CIL as a library\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc8}{\begin{@norefs}\@print{6}\quad{}CIL API Documentation\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc9}{\begin{@norefs}\@print{6.1}\quad{}Using the visitor\end{@norefs}} -\tocitem \@locref{htoc10}{\begin{@norefs}\@print{6.2}\quad{}Interpreted Constructors and Deconstructors\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc11}{\begin{@norefs}\@print{6.2.1}\quad{}Performance considerations for interpreted constructors\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc12}{\begin{@norefs}\@print{6.3}\quad{}Printing and Debugging support\end{@norefs}} -\tocitem \@locref{htoc13}{\begin{@norefs}\@print{6.4}\quad{}Attributes\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc14}{\begin{@norefs}\@print{7}\quad{}The CIL Driver\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc15}{\begin{@norefs}\@print{7.1}\quad{}\t{cilly} Options\end{@norefs}} -\tocitem \@locref{htoc16}{\begin{@norefs}\@print{7.2}\quad{}\t{cilly.asm} Options\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc17}{\begin{@norefs}\@print{8}\quad{}Library of CIL Modules\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc18}{\begin{@norefs}\@print{8.1}\quad{}Control-Flow Graphs\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc19}{\begin{@norefs}\@print{8.1.1}\quad{}The CFG module (new in CIL 1.3.5)\end{@norefs}} -\tocitem \@locref{htoc20}{\begin{@norefs}\@print{8.1.2}\quad{}Simplified control flow\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc21}{\begin{@norefs}\@print{8.2}\quad{}Data flow analysis framework\end{@norefs}} -\tocitem \@locref{htoc22}{\begin{@norefs}\@print{8.3}\quad{}Dominators\end{@norefs}} -\tocitem \@locref{htoc23}{\begin{@norefs}\@print{8.4}\quad{}Points-to Analysis\end{@norefs}} -\tocitem \@locref{htoc24}{\begin{@norefs}\@print{8.5}\quad{}StackGuard\end{@norefs}} -\tocitem \@locref{htoc25}{\begin{@norefs}\@print{8.6}\quad{}Heapify\end{@norefs}} -\tocitem \@locref{htoc26}{\begin{@norefs}\@print{8.7}\quad{}One Return\end{@norefs}} -\tocitem \@locref{htoc27}{\begin{@norefs}\@print{8.8}\quad{}Partial Evaluation and Constant Folding\end{@norefs}} -\tocitem \@locref{htoc28}{\begin{@norefs}\@print{8.9}\quad{}Reaching Definitions\end{@norefs}} -\tocitem \@locref{htoc29}{\begin{@norefs}\@print{8.10}\quad{}Available Expressions\end{@norefs}} -\tocitem \@locref{htoc30}{\begin{@norefs}\@print{8.11}\quad{}Liveness Analysis\end{@norefs}} -\tocitem \@locref{htoc31}{\begin{@norefs}\@print{8.12}\quad{}Dead Code Elimination\end{@norefs}} -\tocitem \@locref{htoc32}{\begin{@norefs}\@print{8.13}\quad{}Simple Memory Operations\end{@norefs}} -\tocitem \@locref{htoc33}{\begin{@norefs}\@print{8.14}\quad{}Simple Three-Address Code\end{@norefs}} -\tocitem \@locref{htoc34}{\begin{@norefs}\@print{8.15}\quad{}Converting C to C++\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc35}{\begin{@norefs}\@print{9}\quad{}Controlling CIL\end{@norefs}} -\tocitem \@locref{htoc36}{\begin{@norefs}\@print{10}\quad{}GCC Extensions\end{@norefs}} -\tocitem \@locref{htoc37}{\begin{@norefs}\@print{11}\quad{}CIL Limitations\end{@norefs}} -\tocitem \@locref{htoc38}{\begin{@norefs}\@print{12}\quad{}Known Bugs and Limitations\end{@norefs}} -\tocitem \@locref{htoc39}{\begin{@norefs}\@print{13}\quad{}Using the merger\end{@norefs}} -\tocitem \@locref{htoc40}{\begin{@norefs}\@print{14}\quad{}Using the patcher\end{@norefs}} -\tocitem \@locref{htoc41}{\begin{@norefs}\@print{15}\quad{}Debugging support\end{@norefs}} -\tocitem \@locref{htoc42}{\begin{@norefs}\@print{16}\quad{}Who Says C is Simple?\end{@norefs}} -\begin{tocenv} -\tocitem \@locref{htoc43}{\begin{@norefs}\@print{16.1}\quad{}Standard C\end{@norefs}} -\tocitem \@locref{htoc44}{\begin{@norefs}\@print{16.2}\quad{}GCC ugliness\end{@norefs}} -\tocitem \@locref{htoc45}{\begin{@norefs}\@print{16.3}\quad{}Microsoft VC ugliness\end{@norefs}} -\end{tocenv} -\tocitem \@locref{htoc46}{\begin{@norefs}\@print{17}\quad{}Authors\end{@norefs}} -\tocitem \@locref{htoc47}{\begin{@norefs}\@print{18}\quad{}License\end{@norefs}} -\tocitem \@locref{htoc48}{\begin{@norefs}\@print{19}\quad{}Bug reports\end{@norefs}} -\tocitem \@locref{htoc49}{\begin{@norefs}\@print{20}\quad{}Changes\end{@norefs}} -\end{tocenv} diff --git a/cil/doc/ciltoc.html b/cil/doc/ciltoc.html deleted file mode 100644 index 7fe4c80..0000000 --- a/cil/doc/ciltoc.html +++ /dev/null @@ -1,92 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - -

- - -
This document was translated from LATEX by -HEVEA.
- diff --git a/cil/doc/contents_motif.gif b/cil/doc/contents_motif.gif deleted file mode 100644 index 5d3d016..0000000 Binary files a/cil/doc/contents_motif.gif and /dev/null differ diff --git a/cil/doc/examples/ex1.txt b/cil/doc/examples/ex1.txt deleted file mode 100644 index 2fe6c21..0000000 --- a/cil/doc/examples/ex1.txt +++ /dev/null @@ -1,16 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex1.c" -long x ; -#line 3 "cilcode.tmp/ex1.c" -static long long y ; -#line 6 "cilcode.tmp/ex1.c" -int main(void) -{ - - { -#line 6 - return ((int )((long long )x + y)); -} -} diff --git a/cil/doc/examples/ex10.txt b/cil/doc/examples/ex10.txt deleted file mode 100644 index 7213b4c..0000000 --- a/cil/doc/examples/ex10.txt +++ /dev/null @@ -1,10 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex10.c" -char foo[13] = -#line 1 - { (char )'f', (char )'o', (char )'o', (char )' ', - (char )'p', (char )'l', (char )'u', (char )'s', - (char )' ', (char )'b', (char )'a', (char )'r', - (char )'\000'}; diff --git a/cil/doc/examples/ex11.txt b/cil/doc/examples/ex11.txt deleted file mode 100644 index 683df51..0000000 --- a/cil/doc/examples/ex11.txt +++ /dev/null @@ -1,5 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex11.c" -char *foo = (char *)"foo plus bar "; diff --git a/cil/doc/examples/ex12.txt b/cil/doc/examples/ex12.txt deleted file mode 100644 index d04d83d..0000000 --- a/cil/doc/examples/ex12.txt +++ /dev/null @@ -1,32 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 2 "cilcode.tmp/ex12.c" -struct foo { - int f1 ; - int f2 ; -}; -#line 1 "cilcode.tmp/ex12.c" -int main(void) -{ int x ; - struct foo a[3] ; - - { -#line 1 - x = 5; -#line 2 - a[0].f1 = 1; -#line 2 - a[0].f2 = 2; -#line 2 - a[1].f1 = 3; -#line 2 - a[1].f2 = 4; -#line 2 - a[2].f1 = 5; -#line 2 - a[2].f2 = 0; -#line 3 - return (0); -} -} diff --git a/cil/doc/examples/ex13.txt b/cil/doc/examples/ex13.txt deleted file mode 100644 index 6486ad6..0000000 --- a/cil/doc/examples/ex13.txt +++ /dev/null @@ -1,21 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex13.c" -int x = 5; -#line 2 "cilcode.tmp/ex13.c" -int main(void) -{ int x___0 ; - int x___1 ; - - { -#line 3 - x___0 = 6; -#line 5 - x___1 = 7; -#line 6 - return (x___1); -#line 8 - return (x___0); -} -} diff --git a/cil/doc/examples/ex14.txt b/cil/doc/examples/ex14.txt deleted file mode 100644 index 72fc719..0000000 --- a/cil/doc/examples/ex14.txt +++ /dev/null @@ -1,22 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex14.c" -int x = 5; -#line 5 -int main(void) ; -#line 5 "cilcode.tmp/ex14.c" -static int x___1 = 7; -#line 2 "cilcode.tmp/ex14.c" -int main(void) -{ int x___0 ; - - { -#line 3 - x___0 = 6; -#line 6 - return (x___1); -#line 8 - return (x___0); -} -} diff --git a/cil/doc/examples/ex15.txt b/cil/doc/examples/ex15.txt deleted file mode 100644 index 4f64ae9..0000000 --- a/cil/doc/examples/ex15.txt +++ /dev/null @@ -1,14 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex15.c" -int foo(void) -{ int x ; - - { -#line 2 - x = 5; -#line 3 - return (0); -} -} diff --git a/cil/doc/examples/ex16.txt b/cil/doc/examples/ex16.txt deleted file mode 100644 index 82290c2..0000000 --- a/cil/doc/examples/ex16.txt +++ /dev/null @@ -1,22 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex16.c" -extern int f(int ) ; -#line 1 "cilcode.tmp/ex16.c" -int main(void) -{ int x ; - int tmp ; - int tmp___0 ; - - { -#line 2 - tmp = x; -#line 2 - x ++; -#line 2 - tmp___0 = f(x); -#line 2 - return (tmp + tmp___0); -} -} diff --git a/cil/doc/examples/ex17.txt b/cil/doc/examples/ex17.txt deleted file mode 100644 index 20bbaa7..0000000 --- a/cil/doc/examples/ex17.txt +++ /dev/null @@ -1,81 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex17.c" -int main(void) -{ int x ; - int y ; - int tmp ; - int z ; - int tmp___0 ; - - { -#line 2 - if (x) { -#line 2 - tmp = 2; - } else { -#line 2 - tmp = 4; - } -#line 2 - y = tmp; -#line 3 - if (x) { -#line 3 - tmp___0 = 1; - } else { -#line 3 - if (y) { -#line 3 - tmp___0 = 1; - } else { -#line 3 - tmp___0 = 0; - } - } -#line 3 - z = tmp___0; -#line 5 - if (x) { -#line 5 - if (y) { -#line 5 - return (0); - } else { -#line 5 - return (1); - } - } else { -#line 5 - return (1); - } -#line 8 - if (x) { -#line 8 - if (y) { - goto _L; - } else { - goto _L___0; - } - } else { - _L___0: /* CIL Label */ -#line 8 - if (z) { - _L: /* CIL Label */ -#line 8 - x ++; -#line 8 - y ++; -#line 8 - z ++; -#line 8 - x ++; -#line 8 - y ++; -#line 8 - return (z); - } - } -} -} diff --git a/cil/doc/examples/ex18.txt b/cil/doc/examples/ex18.txt deleted file mode 100644 index bcdb7ef..0000000 --- a/cil/doc/examples/ex18.txt +++ /dev/null @@ -1,20 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex18.c" -extern int f() ; -#line 1 "cilcode.tmp/ex18.c" -int main(void) -{ int tmp___0 ; - - { -#line 2 - tmp___0 = f(); - if (! tmp___0) { -#line 2 - tmp___0 = 4; - } -#line 2 - return (tmp___0); -} -} diff --git a/cil/doc/examples/ex19.txt b/cil/doc/examples/ex19.txt deleted file mode 100644 index 3b82868..0000000 --- a/cil/doc/examples/ex19.txt +++ /dev/null @@ -1,42 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex19.c" -int main(void) -{ int x ; - int i ; - - { -#line 2 - i = 0; -#line 2 - while (i < 5) { -#line 3 - if (i == 5) { - goto __Cont; - } -#line 4 - if (i == 4) { -#line 4 - break; - } -#line 5 - i += 2; - __Cont: /* CIL Label */ -#line 2 - i ++; - } -#line 7 - while (x < 5) { -#line 8 - if (x == 3) { -#line 8 - continue; - } -#line 9 - x ++; - } -#line 11 - return (0); -} -} diff --git a/cil/doc/examples/ex2.txt b/cil/doc/examples/ex2.txt deleted file mode 100644 index 2031382..0000000 --- a/cil/doc/examples/ex2.txt +++ /dev/null @@ -1,9 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex2.c" -struct __anonstruct_s_1 { - int x ; -}; -#line 1 "cilcode.tmp/ex2.c" -struct __anonstruct_s_1 s ; diff --git a/cil/doc/examples/ex20.txt b/cil/doc/examples/ex20.txt deleted file mode 100644 index 7a51db3..0000000 --- a/cil/doc/examples/ex20.txt +++ /dev/null @@ -1,26 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex20.c" -int main(void) -{ int x ; - int y ; - int z ; - - { -#line 1 - x = 5; -#line 1 - y = x; -#line 2 - x ++; - L: -#line 2 - y -= x; -#line 2 - z = y; - goto L; -#line 3 - return (0); -} -} diff --git a/cil/doc/examples/ex21.txt b/cil/doc/examples/ex21.txt deleted file mode 100644 index 3f331e4..0000000 --- a/cil/doc/examples/ex21.txt +++ /dev/null @@ -1,25 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex21.c" -int main(void) -{ int x ; - int y ; - int z ; - int *tmp ; - - { -#line 2 - if (x) { -#line 2 - tmp = & y; - } else { -#line 2 - tmp = & z; - } -#line 2 - x ++; -#line 2 - return (tmp - & x); -} -} diff --git a/cil/doc/examples/ex22.txt b/cil/doc/examples/ex22.txt deleted file mode 100644 index 2224e7c..0000000 --- a/cil/doc/examples/ex22.txt +++ /dev/null @@ -1,16 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 327 "/usr/include/stdio.h" -extern int printf(char const * __restrict __format , ...) ; -#line 7 "cilcode.tmp/ex22.c" -int main(void) -{ - - { -#line 9 - printf((char const * __restrict )"Hello world\n"); -#line 10 - return (0); -} -} diff --git a/cil/doc/examples/ex23.txt b/cil/doc/examples/ex23.txt deleted file mode 100644 index d48a135..0000000 --- a/cil/doc/examples/ex23.txt +++ /dev/null @@ -1,56 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex23.c" -int foo(int predicate ) -{ int x ; - - { -#line 2 - x = 0; -#line 4 - if (predicate == 0) { - goto switch_0_0; - } else { -#line 5 - if (predicate == 1) { - goto switch_0_1; - } else { -#line 6 - if (predicate == 2) { - goto switch_0_2; - } else { -#line 7 - if (predicate == 3) { - goto switch_0_3; - } else { - { - goto switch_0_default; -#line 3 - if (0) { - switch_0_0: /* CIL Label */ -#line 4 - return (111); - switch_0_1: /* CIL Label */ -#line 5 - x ++; - switch_0_2: /* CIL Label */ -#line 6 - return (x + 3); - switch_0_3: /* CIL Label */ - goto switch_0_break; - switch_0_default: /* CIL Label */ ; -#line 8 - return (222); - } else { - switch_0_break: /* CIL Label */ ; - } - } - } - } - } - } -#line 10 - return (333); -} -} diff --git a/cil/doc/examples/ex24.txt b/cil/doc/examples/ex24.txt deleted file mode 100644 index 587ce67..0000000 --- a/cil/doc/examples/ex24.txt +++ /dev/null @@ -1,59 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -extern void * stackguard_get_ra(); -extern void stackguard_set_ra(void *new_ra); -/* You must provide an implementation for functions that get and set the - * return address. Such code is unfortunately architecture specific. - */ -struct stackguard_stack { - void * data; - struct stackguard_stack * next; -} * stackguard_stack; - -void stackguard_push(void *ra) { - void * old = stackguard_stack; - stackguard_stack = (struct stackguard_stack *) - malloc(sizeof(stackguard_stack)); - stackguard_stack->data = ra; - stackguard_stack->next = old; -} - -void * stackguard_pop() { - void * ret = stackguard_stack->data; - void * next = stackguard_stack->next; - free(stackguard_stack); - stackguard_stack->next = next; - return ret; -} -#line 3 "cilcode.tmp/ex24.c" -extern int ( /* missing proto */ scanf)() ; -#line 1 "cilcode.tmp/ex24.c" -int dangerous(void) -{ char array[10] ; - void *return_address ; - - { - return_address = (void *)stackguard_get_ra(); - stackguard_push(return_address); -#line 3 - scanf("%s", array); - { - return_address = (void *)stackguard_pop(); - stackguard_set_ra(return_address); -#line 4 - return (0); - } -} -} -#line 6 "cilcode.tmp/ex24.c" -int main(void) -{ int tmp ; - - { -#line 7 - tmp = dangerous(); -#line 7 - return (tmp); -} -} diff --git a/cil/doc/examples/ex25.txt b/cil/doc/examples/ex25.txt deleted file mode 100644 index 88f6902..0000000 --- a/cil/doc/examples/ex25.txt +++ /dev/null @@ -1,40 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 3 "cilcode.tmp/ex25.c" -extern int ( /* missing proto */ scanf)() ; -#line 1 "cilcode.tmp/ex25.c" -struct dangerous_heapify { - char array[10] ; -}; -#line 1 "cilcode.tmp/ex25.c" -int dangerous(void) -{ struct dangerous_heapify *dangerous_heapify ; - int __cil_tmp3 ; - - { -#line 1 - dangerous_heapify = (struct dangerous_heapify *)malloc(sizeof(struct dangerous_heapify )); -#line 3 - scanf("%s", dangerous_heapify->array); - { -#line 4 - __cil_tmp3 = 0; -#line 4 - free(dangerous_heapify); -#line 4 - return (__cil_tmp3); - } -} -} -#line 6 "cilcode.tmp/ex25.c" -int main(void) -{ int tmp ; - - { -#line 7 - tmp = dangerous(); -#line 7 - return (tmp); -} -} diff --git a/cil/doc/examples/ex26.txt b/cil/doc/examples/ex26.txt deleted file mode 100644 index 8f5b171..0000000 --- a/cil/doc/examples/ex26.txt +++ /dev/null @@ -1,29 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex26.c" -int foo(int predicate ) -{ int __retres ; - - { -#line 2 - if (predicate <= 0) { -#line 3 - __retres = 1; - goto return_label; - } else { -#line 5 - if (predicate > 5) { -#line 6 - __retres = 2; - goto return_label; - } -#line 7 - __retres = 3; - goto return_label; - } - return_label: /* CIL Label */ -#line 1 - return (__retres); -} -} diff --git a/cil/doc/examples/ex27.txt b/cil/doc/examples/ex27.txt deleted file mode 100644 index 6059113..0000000 --- a/cil/doc/examples/ex27.txt +++ /dev/null @@ -1,51 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex27.c" -int foo(int x , int y ) -{ int unknown ; - - { -#line 3 - if (unknown) { -#line 4 - return (9); - } -#line 5 - return (x + 3); -} -} -#line 8 "cilcode.tmp/ex27.c" -int main(void) -{ int a ; - int b ; - int c ; - int tmp ; - int tmp___0 ; - - { - { -#line 10 - tmp = foo(5, 7); -#line 10 - tmp___0 = foo(6, 7); -#line 10 - a = tmp + tmp___0; -#line 11 - b = 4; -#line 12 - c = 16; - } - { - { -#line 16 - return (20); - } -#line 13 - if (0) { -#line 14 - return (b - c); - } - } -} -} diff --git a/cil/doc/examples/ex28.txt b/cil/doc/examples/ex28.txt deleted file mode 100644 index 098b144..0000000 --- a/cil/doc/examples/ex28.txt +++ /dev/null @@ -1,24 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex28.c" -int main(void) -{ int ***three ; - int **two ; - int **mem_3 ; - int *mem_4 ; - int *mem_5 ; - - { -#line 4 - mem_3 = (*three); -#line 4 - mem_4 = (*mem_3); -#line 4 - mem_5 = (*two); -#line 4 - (*mem_4) = (*mem_5); -#line 5 - return (0); -} -} diff --git a/cil/doc/examples/ex29.txt b/cil/doc/examples/ex29.txt deleted file mode 100644 index 7df8f68..0000000 --- a/cil/doc/examples/ex29.txt +++ /dev/null @@ -1,53 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 2 "cilcode.tmp/ex29.c" -struct mystruct { - int a ; - int b ; -}; -#line 1 "cilcode.tmp/ex29.c" -int main(void) -{ struct mystruct m ; - int local ; - int arr[3] ; - int *ptr ; - unsigned int __cil_tmp5 ; - unsigned int __cil_tmp6 ; - int __cil_tmp7 ; - unsigned int __cil_tmp8 ; - int *__cil_tmp9 ; - int __cil_tmp10 ; - unsigned int __cil_tmp11 ; - unsigned int __cil_tmp12 ; - unsigned int __cil_tmp13 ; - int m_b14 ; - int m_a15 ; - - { -#line 10 - ptr = & local; -#line 11 - __cil_tmp5 = 2 * 4U; -#line 11 - __cil_tmp6 = (unsigned int )(arr) + __cil_tmp5; -#line 11 - __cil_tmp7 = (*((int *)__cil_tmp6)); -#line 11 - __cil_tmp8 = (unsigned int )__cil_tmp7; -#line 11 - __cil_tmp9 = & local; -#line 11 - __cil_tmp10 = (*__cil_tmp9); -#line 11 - __cil_tmp11 = (unsigned int )__cil_tmp10; -#line 11 - __cil_tmp12 = __cil_tmp11 + 8U; -#line 11 - __cil_tmp13 = __cil_tmp12 + __cil_tmp8; -#line 11 - m_a15 = (int )__cil_tmp13; -#line 12 - return (m_a15); -} -} diff --git a/cil/doc/examples/ex3.txt b/cil/doc/examples/ex3.txt deleted file mode 100644 index 2ca8ac9..0000000 --- a/cil/doc/examples/ex3.txt +++ /dev/null @@ -1,20 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex3.c" -union baz { - int x1 ; - double x2 ; -}; -#line 1 "cilcode.tmp/ex3.c" -struct bar { - union baz u1 ; - int y ; -}; -#line 1 "cilcode.tmp/ex3.c" -struct foo { - struct bar s1 ; - int z ; -}; -#line 1 "cilcode.tmp/ex3.c" -struct foo f ; diff --git a/cil/doc/examples/ex30.txt b/cil/doc/examples/ex30.txt deleted file mode 100644 index 729cfb0..0000000 --- a/cil/doc/examples/ex30.txt +++ /dev/null @@ -1,12 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex30.c" -int main(void) -{ int x ; - - { -#line 2 - return (x == (x != 0)); -} -} diff --git a/cil/doc/examples/ex31.txt b/cil/doc/examples/ex31.txt deleted file mode 100644 index ab7d471..0000000 --- a/cil/doc/examples/ex31.txt +++ /dev/null @@ -1,12 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex31.c" -int main(void) -{ - - { -#line 1 - return ((int )((1U - sizeof(int )) >> 32)); -} -} diff --git a/cil/doc/examples/ex32.txt b/cil/doc/examples/ex32.txt deleted file mode 100644 index f2b6b5b..0000000 --- a/cil/doc/examples/ex32.txt +++ /dev/null @@ -1,16 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex32.c" -int x = 5; -#line 2 "cilcode.tmp/ex32.c" -int f(void) -{ int x___0 ; - - { -#line 3 - x___0 = 3; -#line 6 - return (x); -} -} diff --git a/cil/doc/examples/ex33.txt b/cil/doc/examples/ex33.txt deleted file mode 100644 index f73178f..0000000 --- a/cil/doc/examples/ex33.txt +++ /dev/null @@ -1,24 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex33.c" -int (*pf)(void) ; -#line 2 "cilcode.tmp/ex33.c" -int f(void) -{ - - { -#line 4 - pf = & f; -#line 5 - pf = & f; -#line 6 - ((*pf))(); -#line 7 - ((*pf))(); -#line 8 - f(); -#line 9 - return (0); -} -} diff --git a/cil/doc/examples/ex34.txt b/cil/doc/examples/ex34.txt deleted file mode 100644 index 494ca91..0000000 --- a/cil/doc/examples/ex34.txt +++ /dev/null @@ -1,15 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex34.c" -struct __anonstruct_nested_2 { - int y ; - int z ; -}; -#line 1 "cilcode.tmp/ex34.c" -struct __anonstruct_i_1 { - int x ; - struct __anonstruct_nested_2 nested ; -}; -#line 1 "cilcode.tmp/ex34.c" -struct __anonstruct_i_1 i = {1, {2, 6}}; diff --git a/cil/doc/examples/ex35.txt b/cil/doc/examples/ex35.txt deleted file mode 100644 index 1af7447..0000000 --- a/cil/doc/examples/ex35.txt +++ /dev/null @@ -1,32 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex35.c" -struct __anonstruct_T1_1 { - char *key ; - char *value ; -}; -#line 1 "cilcode.tmp/ex35.c" -typedef struct __anonstruct_T1_1 T1; -#line 7 "cilcode.tmp/ex35.c" -struct __anonstruct_T3_2 { - long type ; - char *value ; -}; -#line 7 "cilcode.tmp/ex35.c" -typedef struct __anonstruct_T3_2 T3; -#line 13 "cilcode.tmp/ex35.c" -struct __anonstruct_T3_2 __constr_expr_0 = {1L, (char *)1}; -#line 13 "cilcode.tmp/ex35.c" -T1 a[1] = { {(char *)"", (char *)(& __constr_expr_0)}}; -#line 20 "cilcode.tmp/ex35.c" -int main(void) -{ T3 *pt3 ; - - { -#line 21 - pt3 = (T3 *)a[0].value; -#line 22 - return ((int )pt3->value); -} -} diff --git a/cil/doc/examples/ex36.txt b/cil/doc/examples/ex36.txt deleted file mode 100644 index adbcdaa..0000000 --- a/cil/doc/examples/ex36.txt +++ /dev/null @@ -1,20 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex36.c" -int main(void) -{ int __constr_expr_0[4] ; - - { -#line 1 - __constr_expr_0[0] = 1; -#line 1 - __constr_expr_0[1] = 2; -#line 1 - __constr_expr_0[2] = 3; -#line 1 - __constr_expr_0[3] = 4; -#line 1 - return (__constr_expr_0[1]); -} -} diff --git a/cil/doc/examples/ex37.txt b/cil/doc/examples/ex37.txt deleted file mode 100644 index 00d6ca4..0000000 --- a/cil/doc/examples/ex37.txt +++ /dev/null @@ -1,14 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 3 "cilcode.tmp/ex37.c" -int foo(void) ; -#line 1 "cilcode.tmp/ex37.c" -int foo(void) -{ - - { -#line 5 - return (0); -} -} diff --git a/cil/doc/examples/ex38.txt b/cil/doc/examples/ex38.txt deleted file mode 100644 index 706e13d..0000000 --- a/cil/doc/examples/ex38.txt +++ /dev/null @@ -1,12 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex38.c" -unsigned long foo(void) -{ - - { -#line 2 - return (536870911UL); -} -} diff --git a/cil/doc/examples/ex39.txt b/cil/doc/examples/ex39.txt deleted file mode 100644 index 2c8c25f..0000000 --- a/cil/doc/examples/ex39.txt +++ /dev/null @@ -1,25 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex39.c" -int main(void) -{ int x ; - int y ; - int z ; - int *tmp ; - - { -#line 2 - if (x) { -#line 2 - tmp = & y; - } else { -#line 2 - tmp = & z; - } -#line 2 - x ++; -#line 2 - return (tmp - & x); -} -} diff --git a/cil/doc/examples/ex4.txt b/cil/doc/examples/ex4.txt deleted file mode 100644 index 00a22d3..0000000 --- a/cil/doc/examples/ex4.txt +++ /dev/null @@ -1,16 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 2 "cilcode.tmp/ex4.c" -struct foo { - int x ; -}; -#line 1 "cilcode.tmp/ex4.c" -int main(void) -{ struct foo foo ; - - { -#line 8 - return (foo.x); -} -} diff --git a/cil/doc/examples/ex40.txt b/cil/doc/examples/ex40.txt deleted file mode 100644 index c41496b..0000000 --- a/cil/doc/examples/ex40.txt +++ /dev/null @@ -1,20 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex40.c" -extern int f() ; -#line 1 "cilcode.tmp/ex40.c" -int main(void) -{ int tmp___0 ; - - { -#line 2 - tmp___0 = f(); - if (! tmp___0) { -#line 2 - tmp___0 = -1; - } -#line 2 - return (tmp___0); -} -} diff --git a/cil/doc/examples/ex41.txt b/cil/doc/examples/ex41.txt deleted file mode 100644 index f1196f3..0000000 --- a/cil/doc/examples/ex41.txt +++ /dev/null @@ -1,69 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex41.c" -static void *jtab[2] ; -#line 4 -static int doit(int x ) ; -#line 4 "cilcode.tmp/ex41.c" -static int jtab_init = 0; -#line 2 "cilcode.tmp/ex41.c" -static int doit(int x ) -{ unsigned int __compgoto ; - - { -#line 5 - if (! jtab_init) { -#line 6 - jtab[0] = (void *)0; -#line 7 - jtab[1] = (void *)1; -#line 8 - jtab_init = 1; - } -#line 10 - __compgoto = (unsigned int )jtab[x]; -#line 10 - switch (__compgoto) { - case 1: - goto lbl2; - case 0: - goto lbl1; - default: -#line 10 - (*((int *)0)) = 0; - } - lbl1: -#line 12 - return (0); - lbl2: -#line 14 - return (1); -} -} -#line 18 -extern int ( /* missing proto */ exit)() ; -#line 17 "cilcode.tmp/ex41.c" -int main(void) -{ int tmp ; - int tmp___0 ; - - { -#line 18 - tmp = doit(0); -#line 18 - if (tmp != 0) { -#line 18 - exit(1); - } -#line 19 - tmp___0 = doit(1); -#line 19 - if (tmp___0 != 1) { -#line 19 - exit(1); - } -#line 20 - exit(0); -} -} diff --git a/cil/doc/examples/ex42.txt b/cil/doc/examples/ex42.txt deleted file mode 100644 index b0f40b8..0000000 --- a/cil/doc/examples/ex42.txt +++ /dev/null @@ -1,22 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex42.c" -int main(void) -{ int tmp ; - - { - goto L; -#line 1 - if (0) { - L: -#line 1 - tmp = 1; - } else { -#line 1 - tmp = 0; - } -#line 1 - return (tmp); -} -} diff --git a/cil/doc/examples/ex43.txt b/cil/doc/examples/ex43.txt deleted file mode 100644 index 4104f79..0000000 --- a/cil/doc/examples/ex43.txt +++ /dev/null @@ -1,46 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex43.c" -__inline static int foo__extinline(void) -{ - - { -#line 1 - return (1); -} -} -#line 2 "cilcode.tmp/ex43.c" -int firstuse(void) -{ int tmp ; - - { -#line 2 - tmp = foo__extinline(); -#line 2 - return (tmp); -} -} -#line 5 "cilcode.tmp/ex43.c" -int foo(void) -{ - - { -#line 5 - return (2); -} -} -#line 7 "cilcode.tmp/ex43.c" -int main(void) -{ int tmp ; - int tmp___0 ; - - { -#line 8 - tmp = foo(); -#line 8 - tmp___0 = firstuse(); -#line 8 - return (tmp + tmp___0); -} -} diff --git a/cil/doc/examples/ex44.txt b/cil/doc/examples/ex44.txt deleted file mode 100644 index 06f83ba..0000000 --- a/cil/doc/examples/ex44.txt +++ /dev/null @@ -1,31 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex44.c" -struct s { - int i1 ; - int i2 ; -}; -#line 1 "cilcode.tmp/ex44.c" -union u { - int i ; - struct s s ; -}; -#line 8 "cilcode.tmp/ex44.c" -union u x = {6}; -#line 10 "cilcode.tmp/ex44.c" -int main(void) -{ struct s y ; - union u z ; - - { -#line 11 - y.i1 = 1; -#line 11 - y.i2 = 2; -#line 12 - z.s = y; -#line 13 - return (0); -} -} diff --git a/cil/doc/examples/ex45.txt b/cil/doc/examples/ex45.txt deleted file mode 100644 index aaafca3..0000000 --- a/cil/doc/examples/ex45.txt +++ /dev/null @@ -1,11 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex45.c" -char i8 ; -#line 2 "cilcode.tmp/ex45.c" -short i16 ; -#line 3 "cilcode.tmp/ex45.c" -int i32 ; -#line 4 "cilcode.tmp/ex45.c" -long long i64 ; diff --git a/cil/doc/examples/ex46.txt b/cil/doc/examples/ex46.txt deleted file mode 100644 index 1f87ec2..0000000 --- a/cil/doc/examples/ex46.txt +++ /dev/null @@ -1,23 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex46.c" -static int bar(int x , char y ) -{ - - { -#line 2 - return (x + (int )y); -} -} -#line 6 "cilcode.tmp/ex46.c" -int foo(int x , char y ) -{ int tmp ; - - { -#line 6 - tmp = bar(x, y); -#line 6 - return (tmp); -} -} diff --git a/cil/doc/examples/ex47.txt b/cil/doc/examples/ex47.txt deleted file mode 100644 index cc5c306..0000000 --- a/cil/doc/examples/ex47.txt +++ /dev/null @@ -1,28 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex47.c" -struct __anonstruct____missing_field_name_3 { - int u ; - int v ; -}; -#line 1 "cilcode.tmp/ex47.c" -struct __anonstruct____missing_field_name_2 { - int y ; - int z ; - struct __anonstruct____missing_field_name_3 __annonCompField1 ; -}; -#line 1 "cilcode.tmp/ex47.c" -struct __anonstruct_a_1 { - int x ; - struct __anonstruct____missing_field_name_2 __annonCompField2 ; -}; -#line 1 "cilcode.tmp/ex47.c" -int main(void) -{ struct __anonstruct_a_1 a ; - - { -#line 10 - return ((((a.x + a.__annonCompField2.y) + a.__annonCompField2.z) + a.__annonCompField2.__annonCompField1.u) + a.__annonCompField2.__annonCompField1.v); -} -} diff --git a/cil/doc/examples/ex5.txt b/cil/doc/examples/ex5.txt deleted file mode 100644 index d750bb5..0000000 --- a/cil/doc/examples/ex5.txt +++ /dev/null @@ -1,27 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex5.c" -int f(double x ) ; -#line 3 -int g(double x ) ; -#line 2 "cilcode.tmp/ex5.c" -int f(double x ) -{ int tmp ; - - { -#line 3 - tmp = g(x); -#line 3 - return (tmp); -} -} -#line 5 "cilcode.tmp/ex5.c" -int g(double x ) -{ - - { -#line 6 - return ((int )x); -} -} diff --git a/cil/doc/examples/ex6.txt b/cil/doc/examples/ex6.txt deleted file mode 100644 index c33eb9e..0000000 --- a/cil/doc/examples/ex6.txt +++ /dev/null @@ -1,7 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex6.c" -int a1[3] = { 1, 2, 3}; -#line 2 "cilcode.tmp/ex6.c" -int a2[8] ; diff --git a/cil/doc/examples/ex7.txt b/cil/doc/examples/ex7.txt deleted file mode 100644 index 55434c7..0000000 --- a/cil/doc/examples/ex7.txt +++ /dev/null @@ -1,22 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 2 "cilcode.tmp/ex7.c" -enum __anonenum_x_1 { - FIVE = 5, - SIX = 6, - SEVEN = 7, - FOUR = 4, - EIGHT = 8 -} ; -#line 1 "cilcode.tmp/ex7.c" -int main(void) -{ enum __anonenum_x_1 x ; - - { -#line 2 - x = 5; -#line 8 - return ((int )x); -} -} diff --git a/cil/doc/examples/ex8.txt b/cil/doc/examples/ex8.txt deleted file mode 100644 index 323a41e..0000000 --- a/cil/doc/examples/ex8.txt +++ /dev/null @@ -1,13 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 2 "cilcode.tmp/ex8.c" -struct foo { - int x ; - int y ; -}; -#line 1 "cilcode.tmp/ex8.c" -int a1[5] = { 1, 2, 3, 0, - 0}; -#line 2 "cilcode.tmp/ex8.c" -struct foo s1 = {4, 0}; diff --git a/cil/doc/examples/ex9.txt b/cil/doc/examples/ex9.txt deleted file mode 100644 index 22e976c..0000000 --- a/cil/doc/examples/ex9.txt +++ /dev/null @@ -1,16 +0,0 @@ -/* Generated by CIL v. 1.3.5 */ -/* print_CIL_Input is true */ - -#line 1 "cilcode.tmp/ex9.c" -struct inner { - int z ; -}; -#line 1 "cilcode.tmp/ex9.c" -struct foo { - int x ; - int y ; - int a[5] ; - struct inner inner ; -}; -#line 1 "cilcode.tmp/ex9.c" -struct foo s = {0, 8, {0, 5, 5, 4, 0}, {3}}; diff --git a/cil/doc/ext.html b/cil/doc/ext.html deleted file mode 100644 index 532e225..0000000 --- a/cil/doc/ext.html +++ /dev/null @@ -1,506 +0,0 @@ - - - - - - - - - - - - - -Library of CIL Modules - - - -Previous -Up -Next -
- -

8  Library of CIL Modules


-
-We are developing a suite of modules that use CIL for program analyses and -transformations that we have found useful. You can use these modules directly -on your code, or generally as inspiration for writing similar modules. A -particularly big and complex application written on top of CIL is CCured -(../ccured/index.html).
-
- -

8.1  Control-Flow Graphs

-The Cil.stmt datatype includes fields for intraprocedural -control-flow information: the predecessor and successor statements of -the current statement. This information is not computed by default. -If you want to use the control-flow graph, or any of the extensions in -this section that require it, you have to explicitly ask CIL to -compute the CFG.
-
- -

8.1.1  The CFG module (new in CIL 1.3.5)

-The best way to compute the CFG is with the CFG module. Just invoke -Cfg.computeFileCFG on your file. The Cfg API -describes the rest of actions you can take with this module, including -computing the CFG for one function at a time, or printing the CFG in -dot form.
-
- -

8.1.2  Simplified control flow

-CIL can reduce high-level C control-flow constructs like switch and -continue to lower-level gotos. This completely eliminates some -possible classes of statements from the program and may make the result -easier to analyze (e.g., it simplifies data-flow analysis).
-
-You can invoke this transformation on the command line with ---domakeCFG or programatically with Cil.prepareCFG. -After calling Cil.prepareCFG, you can use Cil.computeCFGInfo -to compute the CFG information and find the successor and predecessor -of each statement.
-
-For a concrete example, you can see how cilly --domakeCFG -transforms the following code (note the fall-through in case 1): -

-  int foo (int predicate) {
-    int x = 0;
-    switch (predicate) {
-      case 0: return 111;
-      case 1: x = x + 1;
-      case 2: return (x+3);
-      case 3: break;
-      default: return 222;
-    }
-    return 333;
-  }
-
-See the CIL output for this -code fragment
-
- -

8.2  Data flow analysis framework

-The Dataflow module (click for the ocamldoc) contains a -parameterized framework for forward and backward data flow -analyses. You provide the transfer functions and this module does the -analysis. You must compute control-flow information (Section 8.1) -before invoking the Dataflow module.
-
- -

8.3  Dominators

-The module Dominators contains the computation of immediate - dominators. It uses the Dataflow module.
-
- -

8.4  Points-to Analysis

-The module ptranal.ml contains two interprocedural points-to -analyses for CIL: Olf and Golf. Olf is the default. -(Switching from olf.ml to golf.ml requires a change in -Ptranal and a recompiling cilly.)
-
-The analyses have the following characteristics: -
  • -Not based on C types (inferred pointer relationships are sound - despite most kinds of C casts) -
  • One level of subtyping -
  • One level of context sensitivity (Golf only) -
  • Monomorphic type structures -
  • Field insensitive (fields of structs are conflated) -
  • Demand-driven (points-to queries are solved on demand) -
  • Handle function pointers -
-The analysis itself is factored into two components: Ptranal, -which walks over the CIL file and generates constraints, and Olf -or Golf, which solve the constraints. The analysis is invoked -with the function Ptranal.analyze_file: Cil.file -> - unit. This function builds the points-to graph for the CIL file -and stores it internally. There is currently no facility for clearing -internal state, so Ptranal.analyze_file should only be called -once.
-
-The constructed points-to graph supports several kinds of queries, -including alias queries (may two expressions be aliased?) and -points-to queries (to what set of locations may an expression point?).
-
-The main interface with the alias analysis is as follows: -
  • -Ptranal.may_alias: Cil.exp -> Cil.exp -> bool. If - true, the two expressions may have the same value. -
  • Ptranal.resolve_lval: Cil.lval -> (Cil.varinfo - list). Returns the list of variables to which the given - left-hand value may point. -
  • Ptranal.resolve_exp: Cil.exp -> (Cil.varinfo list). - Returns the list of variables to which the given expression may - point. -
  • Ptranal.resolve_funptr: Cil.exp -> (Cil.fundec - list). Returns the list of functions to which the given - expression may point. -
-The precision of the analysis can be customized by changing the values -of several flags: -
  • -Ptranal.no_sub: bool ref. - If true, subtyping is disabled. Associated commandline option: - --ptr_unify. -
  • Ptranal.analyze_mono: bool ref. - (Golf only) If true, context sensitivity is disabled and the - analysis is effectively monomorphic. Commandline option: - --ptr_mono. -
  • Ptranal.smart_aliases: bool ref. - (Golf only) If true, “smart” disambiguation of aliases is - enabled. Otherwise, aliases are computed by intersecting points-to - sets. This is an experimental feature. -
  • Ptranal.model_strings: bool ref. - Make the alias analysis model string constants by treating them as - pointers to chars. Commandline option: --ptr_model_strings -
  • Ptranal.conservative_undefineds: bool ref. - Make the most pessimistic assumptions about globals if an undefined - function is present. Such a function can write to every global - variable. Commandline option: --ptr_conservative -
-In practice, the best precision/efficiency tradeoff is achieved by -setting Ptranal.no_sub to false, Ptranal.analyze_mono to -true, and Ptranal.smart_aliases to false. These are the -default values of the flags.
-
-There are also a few flags that can be used to inspect or serialize -the results of the analysis. -
  • -Ptranal.debug_may_aliases. - Print the may-alias relationship of each pair of expressions in the - program. Commandline option: --ptr_may_aliases. -
  • Ptranal.print_constraints: bool ref. - If true, the analysis will print each constraint as it is - generated. -
  • Ptranal.print_types: bool ref. - If true, the analysis will print the inferred type of each - variable in the program.
    -
    -If Ptranal.analyze_mono and Ptranal.no_sub are both - true, this output is sufficient to reconstruct the points-to - graph. One nice feature is that there is a pretty printer for - recursive types, so the print routine does not loop. -
  • Ptranal.compute_results: bool ref. - If true, the analysis will print out the points-to set of each - variable in the program. This will essentially serialize the - points-to graph. -
- -

8.5  StackGuard

-The module heapify.ml contains a transformation similar to the one -described in “StackGuard: Automatic Adaptive Detection and Prevention of -Buffer-Overflow Attacks”, Proceedings of the 7th USENIX Security -Conference. In essence it modifies the program to maintain a separate -stack for return addresses. Even if a buffer overrun attack occurs the -actual correct return address will be taken from the special stack.
-
-Although it does work, this CIL module is provided mainly as an example of -how to perform a simple source-to-source program analysis and -transformation. As an optimization only functions that contain a dangerous -local array make use of the special return address stack.
-
-For a concrete example, you can see how cilly --dostackGuard -transforms the following dangerous code: -

-  int dangerous() {
-    char array[10];
-    scanf("%s",array); // possible buffer overrun!
-  }
-
-  int main () {
-    return dangerous();
-  }
-
-See the CIL output for this -code fragment
-
- -

8.6  Heapify

-The module heapify.ml also contains a transformation that moves all -dangerous local arrays to the heap. This also prevents a number of buffer -overruns.
-
-For a concrete example, you can see how cilly --doheapify -transforms the following dangerous code: -

-  int dangerous() {
-    char array[10];
-    scanf("%s",array); // possible buffer overrun!
-  }
-
-  int main () {
-    return dangerous();
-  }
-
-See the CIL output for this -code fragment
-
- -

8.7  One Return

-The module oneret.ml contains a transformation the ensures that all -function bodies have at most one return statement. This simplifies a number -of analyses by providing a canonical exit-point.
-
-For a concrete example, you can see how cilly --dooneRet -transforms the following code: -

-  int foo (int predicate) {
-    if (predicate <= 0) {
-      return 1;
-    } else {
-      if (predicate > 5)
-        return 2;
-      return 3;
-    }
-  }
-
-See the CIL output for this -code fragment
-
- -

8.8  Partial Evaluation and Constant Folding

-The partial.ml module provides a simple interprocedural partial -evaluation and constant folding data-flow analysis and transformation. This -transformation requires the --domakeCFG option.
-
-For a concrete example, you can see how cilly --domakeCFG --dopartial -transforms the following code (note the eliminated if branch and the -partial optimization of foo): -

-  int foo(int x, int y) {
-    int unknown;
-    if (unknown)
-      return y+2;     
-    return x+3;      
-  }
-
-  int main () {
-    int a,b,c;
-    a = foo(5,7) + foo(6,7);
-    b = 4;
-    c = b * b;      
-    if (b > c)     
-      return b-c;
-    else
-      return b+c; 
-  }
-
-See the CIL output for this -code fragment
-
- -

8.9  Reaching Definitions

-The reachingdefs.ml module uses the dataflow framework and CFG -information to calculate the definitions that reach each -statement. After computing the CFG (Section 8.1) and calling -computeRDs on a -function declaration, ReachingDef.stmtStartData will contain a -mapping from statement IDs to data about which definitions reach each -statement. In particular, it is a mapping from statement IDs to a -triple the first two members of which are used internally. The third -member is a mapping from variable IDs to Sets of integer options. If -the set contains Some(i), then the definition of that variable -with ID i reaches that statement. If the set contains None, -then there is a path to that statement on which there is no definition -of that variable. Also, if the variable ID is unmapped at a -statement, then no definition of that variable reaches that statement.
-
-To summarize, reachingdefs.ml has the following interface: -
  • -computeRDs – Computes reaching definitions. Requires that -CFG information has already been computed for each statement. -
  • ReachingDef.stmtStartData – contains reaching -definition data after computeRDs is called. -
  • ReachingDef.defIdStmtHash – Contains a mapping -from definition IDs to the ID of the statement in which -the definition occurs. -
  • getRDs – Takes a statement ID and returns -reaching definition data for that statement. -
  • instrRDs – Takes a list of instructions and the -definitions that reach the first instruction, and for -each instruction calculates the definitions that reach -either into or out of that instruction. -
  • rdVisitorClass – A subclass of nopCilVisitor that -can be extended such that the current reaching definition -data is available when expressions are visited through -the get_cur_iosh method of the class. -
- -

8.10  Available Expressions

-The availexps.ml module uses the dataflow framework and CFG -information to calculate something similar to a traditional available -expressions analysis. After computeAEs is called following a CFG -calculation (Section 8.1), AvailableExps.stmtStartData will -contain a mapping -from statement IDs to data about what expressions are available at -that statement. The data for each statement is a mapping for each -variable ID to the whole expression available at that point(in the -traditional sense) which the variable was last defined to be. So, -this differs from a traditional available expressions analysis in that -only whole expressions from a variable definition are considered rather -than all expressions.
-
-The interface is as follows: -
  • -computeAEs – Computes available expressions. Requires -that CFG information has already been comptued for each statement. -
  • AvailableExps.stmtStartData – Contains available -expressions data for each statement after computeAEs has been -called. -
  • getAEs – Takes a statement ID and returns -available expression data for that statement. -
  • instrAEs – Takes a list of instructions and -the availalbe expressions at the first instruction, and -for each instruction calculates the expressions available -on entering or exiting each instruction. -
  • aeVisitorClass – A subclass of nopCilVisitor that -can be extended such that the current available expressions -data is available when expressions are visited through the -get_cur_eh method of the class. -
- -

8.11  Liveness Analysis

-The liveness.ml module uses the dataflow framework and -CFG information to calculate which variables are live at -each program point. After computeLiveness is called -following a CFG calculation (Section 8.1), LiveFlow.stmtStartData will -contain a mapping for each statement ID to a set of varinfos -for varialbes live at that program point.
-
-The interface is as follows: -
  • -computeLiveness – Computes live variables. Requires -that CFG information has already been computed for each statement. -
  • LiveFlow.stmtStartData – Contains live variable data -for each statement after computeLiveness has been called. -
-Also included in this module is a command line interface that -will cause liveness data to be printed to standard out for -a particular function or label. -
  • -–doliveness – Instructs cilly to comptue liveness -information and to print on standard out the variables live -at the points specified by –live_func and live_label. -If both are ommitted, then nothing is printed. -
  • –live_func – The name of the function whose -liveness data is of interest. If –live_label is ommitted, -then data for each statement is printed. -
  • –live_label – The name of the label at which -the liveness data will be printed. -
- -

8.12  Dead Code Elimination

-The module deadcodeelim.ml uses the reaching definitions -analysis to eliminate assignment instructions whose results -are not used. The interface is as follows: -
  • -elim_dead_code – Performs dead code elimination -on a function. Requires that CFG information has already -been computed (Section 8.1). -
  • dce – Performs dead code elimination on an -entire file. Requires that CFG information has already -been computed. -
- -

8.13  Simple Memory Operations

-The simplemem.ml module allows CIL lvalues that contain memory -accesses to be even futher simplified via the introduction of -well-typed temporaries. After this transformation all lvalues involve -at most one memory reference.
-
-For a concrete example, you can see how cilly --dosimpleMem -transforms the following code: -

-  int main () {
-    int ***three;
-    int **two;
-    ***three = **two; 
-  } 
-
-See the CIL output for this -code fragment
-
- -

8.14  Simple Three-Address Code

-The simplify.ml module further reduces the complexity of program -expressions and gives you a form of three-address code. After this -transformation all expressions will adhere to the following grammar: -
- basic::=
-    Const _ 
-    Addrof(Var v, NoOffset)
-    StartOf(Var v, NoOffset)
-    Lval(Var v, off), where v is a variable whose address is not taken
-                      and off contains only "basic"
-
- exp::=
-    basic
-    Lval(Mem basic, NoOffset)
-    BinOp(bop, basic, basic)
-    UnOp(uop, basic)
-    CastE(t, basic)
-   
- lval ::= 
-    Mem basic, NoOffset
-    Var v, off, where v is a variable whose address is not taken and off
-                contains only "basic"
-
In addition, all sizeof and alignof forms are turned into -constants. Accesses to arrays and variables whose address is taken are -turned into "Mem" accesses. All field and index computations are turned -into address arithmetic.
-
-For a concrete example, you can see how cilly --dosimplify -transforms the following code: -

-  int main() {
-    struct mystruct {
-      int a;
-      int b;
-    } m;
-    int local;
-    int arr[3];
-    int *ptr;
-
-    ptr = &local;
-    m.a = local + sizeof(m) + arr[2];
-    return m.a; 
-  } 
-
-See the CIL output for this -code fragment
-
- -

8.15  Converting C to C++

-The module canonicalize.ml performs several transformations to correct -differences between C and C++, so that the output is (hopefully) valid -C++ code. This may be incomplete — certain fixes which are necessary -for some programs are not yet implemented.
-
-Using the --doCanonicalize option with CIL will perform the -following changes to your program: -
  1. -Any variables that use C++ keywords as identifiers are renamed. -
  2. C allows global variables to have multiple declarations and - multiple (equivalent) definitions. This transformation removes - all but one declaration and all but one definition. -
  3. __inline is #defined to inline, and __restrict - is #defined to nothing. -
  4. C allows function pointers with no specified arguments to be used on - any argument list. To make C++ accept this code, we insert a cast - from the function pointer to a type that matches the arguments. Of - course, this does nothing to guarantee that the pointer actually has - that type. -
  5. Makes casts from int to enum types explicit. (CIL changes enum - constants to int constants, but doesn't use a cast.) -
-
-Previous -Up -Next - - diff --git a/cil/doc/header.html b/cil/doc/header.html deleted file mode 100644 index cfedee9..0000000 --- a/cil/doc/header.html +++ /dev/null @@ -1,18 +0,0 @@ - - - - - - - -CIL Documentation (v. 1.3.5) - - - - - -

CIL - Infrastructure for C Program Analysis and Transformation (v. 1.3.5)

- - - - diff --git a/cil/doc/index.html b/cil/doc/index.html deleted file mode 100644 index 77ec160..0000000 --- a/cil/doc/index.html +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - -CIL Documentation (v. 1.3.5) - - - - - - - - - - <body> - - <p>This page uses frames, but your browser doesn't support them.</p> - - </body> - - - - \ No newline at end of file diff --git a/cil/doc/merger.html b/cil/doc/merger.html deleted file mode 100644 index 636dd2a..0000000 --- a/cil/doc/merger.html +++ /dev/null @@ -1,167 +0,0 @@ - - - - - - - - - - - - - -Using the merger - - - -Previous -Up -Next -
- -

13  Using the merger


-
-There are many program analyses that are more effective when -done on the whole program.
-
-The merger is a tool that combines all of the C source files in a project -into a single C file. There are two tasks that a merger must perform: -
  1. -Detect what are all the sources that make a project and with what -compiler arguments they are compiled.
    -
    -
  2. Merge all of the source files into a single file. -
-For the first task the merger impersonates a compiler and a linker (both a -GCC and a Microsoft Visual C mode are supported) and it expects to be invoked -(from a build script or a Makefile) on all sources of the project. When -invoked to compile a source the merger just preprocesses the source and saves -the result using the name of the requested object file. By preprocessing at -this time the merger is able to take into account variations in the command -line arguments that affect preprocessing of different source files.
-
-When the merger is invoked to link a number of object files it collects the -preprocessed sources that were stored with the names of the object files, and -invokes the merger proper. Note that arguments that affect the compilation or -linking must be the same for all source files.
-
-For the second task, the merger essentially concatenates the preprocessed -sources with care to rename conflicting file-local declarations (we call this -process alpha-conversion of a file). The merger also attempts to remove -duplicate global declarations and definitions. Specifically the following -actions are taken: -
  • -File-scope names (static globals, names of types defined with -typedef, and structure/union/enumeration tags) are given new names if they -conflict with declarations from previously processed sources. The new name is -formed by appending the suffix ___n, where n is a unique integer -identifier. Then the new names are applied to their occurrences in the file.
    -
    -
  • Non-static declarations and definitions of globals are never renamed. -But we try to remove duplicate ones. Equality of globals is detected by -comparing the printed form of the global (ignoring the line number directives) -after the body has been alpha-converted. This process is intended to remove -those declarations (e.g. function prototypes) that originate from the same -include file. Similarly, we try to eliminate duplicate definitions of -inline functions, since these occasionally appear in include files.
    -
    -
  • The types of all global declarations with the same name from all files -are compared for type isomorphism. During this process, the merger detects all -those isomorphisms between structures and type definitions that are required for the merged program to be legal. Such structure tags and -typenames are coalesced and given the same name.
    -
    -
  • Besides the structure tags and type names that are required to be -isomorphic, the merger also tries to coalesce definitions of structures and -types with the same name from different file. However, in this case the merger -will not give an error if such definitions are not isomorphic; it will just -use different names for them.
    -
    -
  • In rare situations, it can happen that a file-local global in -encountered first and it is not renamed, only to discover later when -processing another file that there is an external symbol with the same name. -In this case, a second pass is made over the merged file to rename the -file-local symbol. -
-Here is an example of using the merger:
-
-The contents of file1.c is: -

-struct foo; // Forward declaration
-extern struct foo *global;
-
-The contents of file2.c is: -

-struct bar {
- int x;
- struct bar *next;
-};
-extern struct bar *global;
-struct foo {
- int y;
-};
-extern struct foo another;
-void main() {
-}
-
-There are several ways in which one might create an executable from these -files: -
  • -
    -gcc file1.c file2.c -o a.out
-

    -
    -
  • -gcc -c file1.c -o file1.o
-gcc -c file2.c -o file2.o
-ld file1.o file2.o -o a.out
-

    -
    -
  • -gcc -c file1.c -o file1.o
-gcc -c file2.c -o file2.o
-ar r libfile2.a file2.o
-gcc file1.o libfile2.a -o a.out
-

    -
    -
  • -gcc -c file1.c -o file1.o
-gcc -c file2.c -o file2.o
-ar r libfile2.a file2.o
-gcc file1.o -lfile2 -o a.out
-
-In each of the cases above you must replace all occurrences of gcc and -ld with cilly --merge, and all occurrences of ar with cilly ---merge --mode=AR. It is very important that the --merge flag be used -throughout the build process. If you want to see the merged source file you -must also pass the --keepmerged flag to the linking phase.
-
-The result of merging file1.c and file2.c is: -

-// from file1.c
-struct foo; // Forward declaration
-extern struct foo *global;
-
-// from file2.c
-struct foo {
- int x;
- struct foo *next;
-};
-struct foo___1 {
- int y;
-};
-extern struct foo___1 another;
-
-
-Previous -Up -Next - - diff --git a/cil/doc/next_motif.gif b/cil/doc/next_motif.gif deleted file mode 100644 index 3f84bac..0000000 Binary files a/cil/doc/next_motif.gif and /dev/null differ diff --git a/cil/doc/patcher.html b/cil/doc/patcher.html deleted file mode 100644 index 2c727e2..0000000 --- a/cil/doc/patcher.html +++ /dev/null @@ -1,126 +0,0 @@ - - - - - - - - - - - - - -Using the patcher - - - -Previous -Up -Next -
- -

14  Using the patcher


-
-Occasionally we have needed to modify slightly the standard include files. -So, we developed a simple mechanism that allows us to create modified copies -of the include files and use them instead of the standard ones. For this -purpose we specify a patch file and we run a program caller Patcher which -makes modified copies of include files and applies the patch.
-
-The patcher is invoked as follows: -
-bin/patcher [options]
-
-Options:
-  --help       Prints this help message
-  --verbose    Prints a lot of information about what is being done
-  --mode=xxx   What tool to emulate: 
-                GNUCC     - GNU CC
-                MSVC      - MS VC cl compiler
-
-  --dest=xxx   The destination directory. Will make one if it does not exist
-  --patch=xxx  Patch file (can be specified multiple times)
-  --ppargs=xxx An argument to be passed to the preprocessor (can be specified
-               multiple times)
-
-  --ufile=xxx  A user-include file to be patched (treated as \#include "xxx")
-  --sfile=xxx  A system-include file to be patched (treated as \#include <xxx>)
- 
-  --clean       Remove all files in the destination directory
-  --dumpversion Print the version name used for the current compiler
-
- All of the other arguments are passed to the preprocessor. You should pass
- enough arguments (e.g., include directories) so that the patcher can find the
- right include files to be patched.
-
- Based on the given mode and the current version of the compiler (which -the patcher can print when given the dumpversion argument) the patcher -will create a subdirectory of the dest directory (say /usr/home/necula/cil/include), such as: -
-/usr/home/necula/cil/include/gcc_2.95.3-5
-
- In that file the patcher will copy the modified versions of the include files -specified with the ufile and sfile options. Each of these options can -be specified multiple times.
-
-The patch file (specified with the patch option) has a format inspired by -the Unix patch tool. The file has the following grammar: -
-<<< flags
-patterns
-===
-replacement
->>>
-
- The flags are a comma separated, case-sensitive, sequence of keywords or -keyword = value. The following flags are supported: -
  • -file=foo.h - will only apply the patch on files whose name is - foo.h. -
  • optional - this means that it is Ok if the current patch does not -match any of the processed files. -
  • group=foo - will add this patch to the named group. If this is not -specified then a unique group is created to contain just the current patch. -When all files specified in the command line have been patched, an error -message is generated for all groups for whom no member patch was used. We use -this mechanism to receive notice when the patch triggers are out-dated with -respect to the new include files. -
  • system=sysname - will only consider this pattern on a given -operating system. The “sysname” is reported by the “$Ô” variable in -Perl, except that Windows is always considered to have sysname -“cygwin.” For Linux use “linux” (capitalization matters). -
  • ateof - In this case the patterns are ignored and the replacement -text is placed at the end of the patched file. Use the file flag if you -want to restrict the files in which this replacement is performed. -
  • atsof - The patterns are ignored and the replacement text is placed -at the start of the patched file. Uf the file flag to restrict the -application of this patch to a certain file. -
  • disabled - Use this flag if you want to disable the pattern. -
-The patterns can consist of several groups of lines separated by the ||| -marker. Each of these group of lines is a multi-line pattern that if found in -the file will be replaced with the text given at the end of the block.
-
-The matching is space-insensitive.
-
-All of the markers <<<, |||, === and >>> must appear at the -beginning of a line but they can be followed by arbitrary text (which is -ignored).
-
-The replacement text can contain the special keyword @__pattern__@, -which is substituted with the pattern that matched.
-
-
-Previous -Up -Next - - diff --git a/cil/doc/previous_motif.gif b/cil/doc/previous_motif.gif deleted file mode 100644 index 8c8a3e6..0000000 Binary files a/cil/doc/previous_motif.gif and /dev/null differ diff --git a/cil/install-sh b/cil/install-sh deleted file mode 100644 index e9de238..0000000 --- a/cil/install-sh +++ /dev/null @@ -1,251 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# This comes from X11R5 (mit/util/scripts/install.sh). -# -# Copyright 1991 by the Massachusetts Institute of Technology -# -# Permission to use, copy, modify, distribute, and sell this software and its -# documentation for any purpose is hereby granted without fee, provided that -# the above copyright notice appear in all copies and that both that -# copyright notice and this permission notice appear in supporting -# documentation, and that the name of M.I.T. not be used in advertising or -# publicity pertaining to distribution of the software without specific, -# written prior permission. M.I.T. makes no representations about the -# suitability of this software for any purpose. It is provided "as is" -# without express or implied warranty. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -else - true -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d $dst ]; then - instcmd=: - chmodcmd="" - else - instcmd=mkdir - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f $src -o -d $src ] - then - true - else - echo "install: $src does not exist" - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "install: no destination specified" - exit 1 - else - true - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d $dst ] - then - dst="$dst"/`basename $src` - else - true - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' -' -IFS="${IFS-${defaultIFS}}" - -oIFS="${IFS}" -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS="${oIFS}" - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp="${pathcomp}${1}" - shift - - if [ ! -d "${pathcomp}" ] ; - then - $mkdirprog "${pathcomp}" - else - true - fi - - pathcomp="${pathcomp}/" -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd $dst && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename $dst` - else - dstfile=`basename $dst $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename $dst` - else - true - fi - -# Make a temp file name in the proper directory. - - dsttmp=$dstdir/#inst.$$# - -# Move or copy the file name to the temp name - - $doit $instcmd $src $dsttmp && - - trap "rm -f ${dsttmp}" 0 && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && - -# Now rename the file to the real destination. - - $doit $rmcmd -f $dstdir/$dstfile && - $doit $mvcmd $dsttmp $dstdir/$dstfile - -fi && - - -exit 0 diff --git a/cil/lib/Cilly.pm b/cil/lib/Cilly.pm deleted file mode 100644 index fa7aa53..0000000 --- a/cil/lib/Cilly.pm +++ /dev/null @@ -1,2137 +0,0 @@ -# -# -# Copyright (c) 2001-2002, -# George C. Necula -# Scott McPeak -# Wes Weimer -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# 3. The names of the contributors may not be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -# - - - -# This module implements a compiler stub that parses the command line -# arguments of gcc and Microsoft Visual C (along with some arguments for the -# script itself) and gives hooks into preprocessing, compilation and linking. - - -$::cilbin = 'bin'; - -package Cilly; -@ISA = (); - -use strict; -use File::Basename; -use File::Copy; -use File::Spec; -use Data::Dumper; -use Carp; -use Text::ParseWords; - -use KeptFile; -use OutputFile; -use TempFile; - -$Cilly::savedSourceExt = "_saved.c"; - -# Pass to new a list of command arguments -sub new { - my ($proto, @args) = @_; - - my $class = ref($proto) || $proto; - - my $ref = - { CFILES => [], # C input files - SFILES => [], # Assembly language files - OFILES => [], # Other input files - IFILES => [], # Already preprocessed files - EARLY_PPARGS => [], # Preprocessor args, first (pre-CIL) pass only - PPARGS => [], # Preprocessor args - CCARGS => [], # Compiler args - LINKARGS => [], # Linker args - NATIVECAML => 1, # this causes the native code boxer to be used - RELEASELIB => 0, # if true, use the release runtime library (if any) - # IDASHI => 1, # if true, pass "-I-" to gcc's preprocessor - IDASHDOT => 1, # if true, pass "-I." to gcc's preprocessor - VERBOSE => 0, # when true, print extra detail - TRACE_COMMANDS => 1, # when true, echo commands being run - SEPARATE => ! $::default_is_merge, - LIBDIR => [], - OPERATION => 'TOEXE', # This is the default for all compilers - }; - my $self = bless $ref, $class; - - if(! @args) { - print "No arguments passed\n"; - $self->printHelp(); - exit 0; - } - # Look for the --mode argument first. If not found it is GCC - my $mode = $::default_mode; - { - my @args1 = (); - foreach my $arg (@args) { - if($arg =~ m|--mode=(.+)$|) { - $mode = $1; - } else { - push @args1, $arg; - } - } - @args = @args1; # These are the argument after we extracted the --mode - - } - if(defined $self->{MODENAME} && $self->{MODENAME} ne $mode) { - die "Cannot re-specify the compiler"; - } - { - my $compiler; - if($mode eq "MSVC") { - unshift @Cilly::ISA, qw(MSVC); - $compiler = MSVC->new($self); - } elsif($mode eq "GNUCC") { - unshift @Cilly::ISA, qw(GNUCC); - $compiler = GNUCC->new($self); - } elsif($mode eq "MSLINK") { - unshift @Cilly::ISA, qw(MSLINK); - $compiler = MSLINK->new($self); - } elsif($mode eq "MSLIB") { - unshift @Cilly::ISA, qw(MSLIB); - $compiler = MSLIB->new($self); - } elsif($mode eq "AR") { - unshift @Cilly::ISA, qw(AR); - $compiler = AR->new($self); - } else { - die "Don't know about compiler $mode\n"; - } - # Now grab the fields from the compiler and put them inside self - my $key; - foreach $key (keys %{$compiler}) { - $self->{$key} = $compiler->{$key}; - } - - # For MSVC we have to use --save-temps because otherwise the - # temporary files get deleted somehow before CL gets at them ! - if($mode ne "GNUCC" && $mode ne "AR") { - $self->{SAVE_TEMPS} = '.'; - } - } - - # Scan and process the arguments - $self->setDefaultArguments; - collectArgumentList($self, @args); - - # sm: if an environment variable is set, then do not merge; this - # is intended for use in ./configure scripts, where merging delays - # the reporting of errors that the script is expecting - if (defined($ENV{"CILLY_NOMERGE"})) { - $self->{SEPARATE} = 1; - if($self->{VERBOSE}) { print STDERR "Merging disabled by CILLY_NOMERGE\n"; } - } - -# print Dumper($self); - - return $self; -} - -# Hook to let subclasses set/override default arguments -sub setDefaultArguments { -} - -# work through an array of arguments, processing each one -sub collectArgumentList { - my ($self, @args) = @_; - - # Scan and process the arguments - while($#args >= 0) { - my $arg = $self->fetchNextArg(\@args); - - if(! defined($arg)) { - last; - } - if($arg eq "") { next; } - - #print("arg: $arg\n"); -# -# my $arg = shift @args; # Grab the next one - if(! $self->collectOneArgument($arg, \@args)) { - print "Warning: Unknown argument $arg\n"; - push @{$self->{CCARGS}}, $arg; - } - } -} - -# Grab the next argument -sub fetchNextArg { - my ($self, $pargs) = @_; - return shift @{$pargs}; -} - -# Collecting arguments. Take a look at one argument. If we understand it then -# we return 1. Otherwise we return 0. Might pop some more arguments from pargs. -sub collectOneArgument { - my($self, $arg, $pargs) = @_; - my $res; - # Maybe it is a compiler option or a source file - if($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) { return 1; } - - if($arg eq "--help" || $arg eq "-help") { - $self->printVersion(); - $self->printHelp(); - exit 1; - } - if($arg eq "--version" || $arg eq "-version") { - $self->printVersion(); exit 0; - } - if($arg eq "--verbose") { - $self->{VERBOSE} = 1; return 1; - } - if($arg eq "--flatten_linker_scripts") { - $self->{FLATTEN_LINKER_SCRIPTS} = 1; return 1; - } - if($arg eq '--nomerge') { - $self->{SEPARATE} = 1; - return 1; - } - if($arg eq '--merge') { - $self->{SEPARATE} = 0; - return 1; - } - if($arg =~ "--ccargs=(.+)\$") { - push @{$self->{CCARGS}}, $1; - return 1; - } - if($arg eq '--trueobj') { - $self->{TRUEOBJ} = 1; - return 1; - } - # zf: force curing when linking to a lib - if ($arg eq '--truelib') { - $self->{TRUELIB} = 1; - return 1; - } - if($arg eq '--keepmerged') { - $self->{KEEPMERGED} = 1; - return 1; - } - if($arg eq '--stdoutpp') { - $self->{STDOUTPP} = 1; - return 1; - } - if($arg =~ m|--save-temps=(.+)$|) { - if(! -d $1) { - die "Cannot find directory $1"; - } - $self->{SAVE_TEMPS} = $1; - return 1; - } - if($arg eq '--save-temps') { - $self->{SAVE_TEMPS} = '.'; - return 1; - } - if($arg =~ m|--leavealone=(.+)$|) { - push @{$self->{LEAVEALONE}}, $1; - return 1; - } - if($arg =~ m|--includedir=(.+)$|) { - push @{$self->{INCLUDEDIR}}, $1; return 1; - } - if($arg =~ m|--stages|) { - $self->{SHOWSTAGES} = 1; - push @{$self->{CILARGS}}, $arg; - return 1; - } - if($arg eq "--bytecode") { - $self->{NATIVECAML} = 0; return 1; - } -# if($arg eq "--no-idashi") { -# $self->{IDASHI} = 0; return 1; -# } - if($arg eq "--no-idashdot") { - $self->{IDASHDOT} = 0; return 1; - } - - # sm: response file - if($arg =~ m|-@(.+)$| || - (($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") && $arg =~ m|@(.+)$|)) { - my $fname = $1; # name of response file - &classifyArgDebug("processing response file: $fname\n"); - - # read the lines into an array - if (!open(RF, "<$fname")) { - die("cannot open response file $fname: $!\n"); - } - my @respArgs = (); - while() { - # Drop spaces and empty lines - my ($middle) = ($_ =~ m|\s*(\S.*\S)\s*|); - if($middle ne "") { - # Sometimes we have multiple arguments in one line :-() - if($middle =~ m|\s| && - $middle !~ m|[\"]|) { - # Contains spaces and no quotes - my @middles = split(/\s+/, $middle); - push @respArgs, @middles; - } else { - push @respArgs, $middle; - } -# print "Arg:$middle\n"; - } - } - close(RF) or die; - - - # Scan and process the arguments - collectArgumentList($self, @respArgs); - - #print("done with response file: $fname\n"); - return 1; # argument undestood - } - if($arg eq "-@" || ($self->{MODENAME} eq "MSVC" && $arg eq "@")) { - # sm: I didn't implement the case where it takes the next argument - # because I wasn't sure how to grab add'l args (none of the - # cases above do..) - die("For ccured/cilly, please don't separate the -@ from the\n", - "response file name. e.g., use -@", "respfile.\n"); - } - - # Intercept the --out argument - if($arg =~ m|^--out=(\S+)$|) { - $self->{CILLY_OUT} = $1; - push @{$self->{CILARGS}}, "--out", $1; - return 1; - } - # All other arguments starting with -- are passed to CIL - if($arg =~ m|^--|) { - # Split the == - if($arg =~ m|^(--\S+)=(.+)$|) { - push @{$self->{CILARGS}}, $1, $2; return 1; - } else { - push @{$self->{CILARGS}}, $arg; return 1; - } - } - return 0; -} - - -sub printVersion { - system ($CilCompiler::compiler, '--version'); -} - -sub printHelp { - my($self) = @_; - $self->usage(); - print <helpMessage(); -} - -# For printing the first line of the help message -sub usage { - my ($self) = @_; - print ""; -} - -# The rest of the help message -sub helpMessage { - my ($self) = @_; - print <{OUTLIB} . $dest); - # Pass the linkargs last because some libraries must be passed after - # the sources - my @cmd = (@{$self->{LDLIB}}, @dest, @{$ppargs}, @{$ccargs}, @sources, @{$ldargs}); - return $self->runShell(@cmd); -} - -# Customize the linking into libraries -sub linktolib { - my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - if($self->{VERBOSE}) { print STDERR "Linking into library $dest\n"; } - - # Now collect the files to be merged - my ($tomerge, $trueobjs, $ccargs) = - $self->separateTrueObjects($psrcs, $ccargs); - - if($self->{SEPARATE} || @{$tomerge} == 0) { - # Not merging. Regular linking. - - return $self->straight_linktolib($psrcs, $dest, - $ppargs, $ccargs, $ldargs); - } - # We are merging. Merge all the files into a single one - - if(@{$trueobjs} > 0) { - # We have some true objects. Save them into an additional file - my $trueobjs_file = "$dest" . "_trueobjs"; - if($self->{VERBOSE}) { - print STDERR - "Saving additional true object files in $trueobjs_file\n"; - } - open(TRUEOBJS, ">$trueobjs_file") || die "Cannot write $trueobjs_file"; - foreach my $true (@{$trueobjs}) { - my $abs = File::Spec->rel2abs($true); - print TRUEOBJS "$abs\n"; - } - close(TRUEOBJS); - } - if(@{$tomerge} == 1) { # Just copy the file over - (!system('cp', '-f', ${$tomerge}[0], $dest)) - || die "Cannot copy ${$tomerge}[0] to $dest\n"; - return ; - } - # - # We must do real merging - # - # Prepare the name of the CIL output file based on dest - my ($base, $dir, $ext) = fileparse($dest, "(\\.[^.]+)"); - - # Now prepare the command line for invoking cilly - my ($aftercil, @cmd) = $self->MergeCommand ($psrcs, $dir, $base); - die unless $cmd[0]; - - if($self->{MODENAME} eq "MSVC") { - push @cmd, "--MSVC"; - } - if($self->{VERBOSE}) { - push @cmd, "--verbose"; - } - if(defined $self->{CILARGS}) { - push @cmd, @{$self->{CILARGS}}; - } - # Eliminate duplicates - - # Add the arguments - if(@{$tomerge} > 20) { - my $extraFile = "___extra_files"; - open(TOMERGE, ">$extraFile") || die $!; - #FRANJO added the following on February 15th, 2005 - #REASON: extrafiles was TempFIle=HASH(0x12345678) - # instead of actual filename - my @normalized = @{$tomerge} ; - $_ = (ref $_ ? $_->filename : $_) foreach @normalized; - foreach my $fl (@normalized) { - print TOMERGE "$fl\n"; - } - close(TOMERGE); - push @cmd, '--extrafiles', $extraFile; - } else { - push @cmd, @{$tomerge}; - } - push @cmd, "--mergedout", $dest; - # Now run cilly - return $self->runShell(@cmd); -} - -############ -############ PREPROCESSING -############ -# -# All flavors of preprocessing return the destination file -# - -# THIS IS THE ENTRY POINT FOR COMPILING SOURCE FILES -sub preprocess_compile { - my ($self, $src, $dest, $early_ppargs, $ppargs, $ccargs) = @_; - &mydebug("preprocess_compile(src=$src, dest=$dest)\n"); - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - - my ($base, $dir, $ext) = fileparse($src, "\\.[^.]+"); - if($ext eq ".c" || $ext eq ".cpp" || $ext eq ".cc") { - if($self->leaveAlone($src)) { - print "Leaving alone $src\n"; - # We leave this alone. So just compile as usual - return $self->straight_compile($src, $dest, $early_ppargs, $ppargs, $ccargs); - } - my $out = $self->preprocessOutputFile($src); - $out = $self->preprocess($src, $out, - [@{$early_ppargs}, @{$ppargs}, - "$self->{DEFARG}CIL=1"]); - return $self->compile($out, $dest, $ppargs, $ccargs); - } - if($ext eq ".i") { - return $self->compile($src, $dest, $ppargs, $ccargs); - } - if($ext eq ".$::cilbin") { - return $self->compile($src, $dest, $ppargs, $ccargs); - } -} - -# THIS IS THE ENTRY POINT FOR JUST PREPROCESSING A FILE -sub preprocess { - my($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - return $self->preprocess_before_cil($src, $dest, $ppargs); -} - -# Find the name of the preprocessed file before CIL processing -sub preprocessOutputFile { - my($self, $src) = @_; - return $self->outputFile($src, 'i'); -} - -# Find the name of the preprocessed file after CIL processing -sub preprocessAfterOutputFile { - my($self, $src) = @_; - return $self->outputFile($src, 'cil.i'); -} - -# When we use CIL we have two separate preprocessing stages. First is the -# preprocessing before the CIL sees the code and the is the preprocessing -# after CIL sees the code - -sub preprocess_before_cil { - my ($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - my @args = @{$ppargs}; - - # See if we must force some includes - if(defined $self->{INCLUDEDIR} && !defined($ENV{"CILLY_NOCURE"})) { - # And force the other includes. Put them at the begining - if(($self->{MODENAME} eq 'GNUCC') && - # sm: m88k doesn't work if I pass -I. - $self->{IDASHDOT}) { - unshift @args, "-I."; - } - if(! defined($self->{VERSION})) { - $self->setVersion(); - } - unshift @args, - map { my $dir = $_; - $self->{INCARG} . $dir . "/" . $self->{VERSION} } - @{$self->{INCLUDEDIR}}; - #matth: include the main include dir as well as the compiler-specific directory - unshift @args, - map { my $dir = $_; - $self->{INCARG} . $dir } - @{$self->{INCLUDEDIR}}; - if($self->{MODENAME} eq 'GNUCC') { - # sm: this is incompatible with wu-ftpd, but is apparently needed - # for apache.. more investigation is needed - # update: now when I try it, apache works without -I- also.. but - # I'll make this into a switchable flag anyway - # matth: this breaks other tests. Let's try without. -# if ($self->{IDASHI}) { -# unshift @args, "-I-"; -# } - } - } - - return $self->straight_preprocess($src, $dest, \@args); -} - -# Preprocessing after CIL -sub preprocess_after_cil { - my ($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - return $self->straight_preprocess($src, $dest, $ppargs); -} - -# -# This is intended to be the true invocation of the underlying preprocessor -# You should not override this method -sub straight_preprocess { - my ($self, $src, $dest, $ppargs) = @_; - Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); - if($self->{VERBOSE}) { - my $srcname = ref $src ? $src->filename : $src; - print STDERR "Preprocessing $srcname\n"; - } - if($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { - $self->MSVC::msvc_preprocess($src, $dest, $ppargs); - } else { -# print Dumper($self); - my @cmd = (@{$self->{CPP}}, @{$ppargs}, - $src, $self->makeOutArguments($self->{OUTCPP}, $dest)); - $self->runShell(@cmd); - - } - return $dest; -} - - -# -# -# -# COMPILATION -# -# - -sub compile { - my($self, $src, $dest, $ppargs, $ccargs) = @_; - &mydebug("Cilly.compile(src=$src, dest=$dest->{filename})\n"); - Carp::confess "bad dest: $dest->{filename}" - unless $dest->isa('OutputFile'); - - if($self->{SEPARATE}) { - # Now invoke CIL and compile afterwards - return $self->applyCilAndCompile([$src], $dest, $ppargs, $ccargs); - } - # We are merging - # If we are merging then we just save the preprocessed source - my ($mtime, $res, $outfile); - if(! $self->{TRUEOBJ}) { - $outfile = $dest->{filename}; $mtime = 0; $res = $dest; - } else { - # Do the real compilation - $res = $self->straight_compile($src, $dest, $ppargs, $ccargs); - # Now stat the result - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($dest->{filename}); - if(! defined($mtime_1)) { - die "Cannot stat the result of compilation $dest->{filename}"; - } - $mtime = $mtime_1; - $outfile = $dest->{filename} . $Cilly::savedSourceExt; - } - my $srcname = ref $src ? $src->filename : $src; - if($self->{VERBOSE}) { - print STDERR "Saving source $srcname into $outfile\n"; - } - open(OUT, ">$outfile") || die "Cannot create $outfile"; - my $toprintsrc = $srcname; - $toprintsrc =~ s|\\|/|g; - print OUT "#pragma merger($mtime,\"$toprintsrc\",\"" . - join(',', @{$ccargs}), "\")\n"; - open(IN, '<', $srcname) || die "Cannot read $srcname"; - while() { - print OUT $_; - } - close(OUT); - close(IN); - return $res; -} - -sub makeOutArguments { - my ($self, $which, $dest) = @_; - $dest = $dest->{filename} if ref $dest; - if($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { - # A single argument - return ("$which$dest"); - } else { - return ($which, $dest); - } -} -# This is the actual invocation of the underlying compiler. You should not -# override this -sub straight_compile { - my ($self, $src, $dest, $ppargs, $ccargs) = @_; - if($self->{VERBOSE}) { - print STDERR 'Compiling ', ref $src ? $src->filename : $src, ' into ', - $dest->filename, "\n"; - } - my @dest = - $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); - my @forcec = @{$self->{FORCECSOURCE}}; - my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, - @dest, @forcec, $src); - return $self->runShell(@cmd); -} - -# This is compilation after CIL -sub compile_cil { - my ($self, $src, $dest, $ppargs, $ccargs) = @_; - return $self->straight_compile($src, $dest, $ppargs, $ccargs); -} - - - -# THIS IS THE ENTRY POINT FOR JUST ASSEMBLING FILES -sub assemble { - my ($self, $src, $dest, $ppargs, $ccargs) = @_; - if($self->{VERBOSE}) { print STDERR "Assembling $src\n"; } - my @dest = - $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); - my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, - @dest, $src); - return $self->runShell(@cmd); -} - - - -# -# This is intended to be the true invocation of the underlying linker -# You should not override this method -sub straight_link { - my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - my @sources = ref($psrcs) ? @{$psrcs} : ($psrcs); - my @dest = - $dest eq "" ? () : $self->makeOutArguments($self->{OUTEXE}, $dest); - # Pass the linkargs last because some libraries must be passed after - # the sources - my @cmd = (@{$self->{LD}}, @dest, - @{$ppargs}, @{$ccargs}, @sources, @{$ldargs}); - return $self->runShell(@cmd); -} - -# -# See if some libraries are actually lists of files -sub expandLibraries { - my ($self) = @_; - - my @tolink = @{$self->{OFILES}}; - - # Go through the sources and replace all libraries with the files that - # they contain - my @tolink1 = (); - while($#tolink >= 0) { - my $src = shift @tolink; -# print "Looking at $src\n"; - # See if the source is a library. Then maybe we should get instead the - # list of files - if($src =~ m|\.$self->{LIBEXT}$| && -f "$src.files") { - open(FILES, "<$src.files") || die "Cannot read $src.files"; - while() { - # Put them back in the "tolink" to process them recursively - while($_ =~ m|[\r\n]$|) { - chop; - } - unshift @tolink, $_; - } - close(FILES); - next; - } - # This is not for us - push @tolink1, $src; - next; - } - $self->{OFILES} = \@tolink1; -} - -# Go over a list of object files and separate them into those that are -# actually sources to be merged, and the true object files -# -sub separateTrueObjects { - my ($self, $psrcs, $ccargs) = @_; - - my @sources = @{$psrcs}; -# print "Sources are @sources\n"; - my @tomerge = (); - my @othersources = (); - - my @ccmerged = @{$ccargs}; - foreach my $src (@sources) { - my ($combsrc, $combsrcname, $mtime); - my $srcname = ref $src ? $src->filename : $src; - if(! $self->{TRUEOBJ}) { - # We are using the object file itself to save the sources - $combsrcname = $srcname; - $combsrc = $src; - $mtime = 0; - } else { - $combsrcname = $srcname . $Cilly::savedSourceExt; - $combsrc = $combsrcname; - if(-f $combsrcname) { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($srcname); - $mtime = $mtime_1; - } else { - $mtime = 0; - } - } - # Look inside and see if it is one of the files created by us - open(IN, "<$combsrcname") || die "Cannot read $combsrcname"; - my $fstline = ; - close(IN); - if($fstline =~ m|CIL|) { - goto ToMerge; - } - if($fstline =~ m|^\#pragma merger\((\d+),\".*\",\"(.*)\"\)$|) { - my $mymtime = $1; - # Get the CC flags - my @thisccargs = split(/,/, $2); - foreach my $arg (@thisccargs) { - # print "Looking at $arg\n ccmerged=@ccmerged\n"; - if(! grep(/$arg/, @ccmerged)) { - # print " adding it\n"; - push @ccmerged, $arg - } - } - ToMerge: - if($mymtime == $mtime) { # It is ours - # See if we have this already - if(! grep { $_ eq $srcname } @tomerge) { # It is ours - push @tomerge, $combsrc; - # See if there is a a trueobjs file also - my $trueobjs = $combsrcname . "_trueobjs"; - if(-f $trueobjs) { - open(TRUEOBJS, "<$trueobjs") - || die "Cannot read $trueobjs"; - while() { - chop; - push @othersources, $_; - } - close(TRUEOBJS); - } - } - next; - } - } - push @othersources, $combsrc; - } - # If we are merging, turn off "warnings are errors" flag - if(grep(/$self->{WARNISERROR}/, @ccmerged)) { - @ccmerged = grep(!/$self->{WARNISERROR}/, @ccmerged); - print STDERR "Turning off warn-is-error flag $self->{WARNISERROR}\n"; - } - - return (\@tomerge, \@othersources, \@ccmerged); -} - - -# Customize the linking -sub link { - my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - my $destname = ref $dest ? $dest->filename : $dest; - if($self->{SEPARATE}) { - if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { - if($self->{VERBOSE}) { print STDERR "Linking into $destname\n"; } - # Not merging. Regular linking. - return $self->link_after_cil($psrcs, $dest, - $ppargs, $ccargs, $ldargs); - } - else { - return 0; # sm: is this value used?? - } - } - my $mergedobj = new OutputFile($destname, - "${destname}_comb.$self->{OBJEXT}"); - - # We must merge - if($self->{VERBOSE}) { - print STDERR "Merging saved sources into $mergedobj->{filename} (in process of linking $destname)\n"; - } - - # Now collect the files to be merged - - my ($tomerge, $trueobjs, $ccargs) = - $self->separateTrueObjects($psrcs, $ccargs); - - if($self->{VERBOSE}) { - print STDERR "Will merge the following: ", - join(' ', @{$tomerge}), "\n"; - print STDERR "Will just link the genuine object files: ", - join(' ', @{$trueobjs}), "\n"; - print STDERR "After merge compile flags: @{$ccargs}\n"; - } - # Check the modification times and see if we can just use the combined - # file instead of merging all over again - if(@{$tomerge} > 1 && $self->{KEEPMERGED}) { - my $canReuse = 1; - my $combFile = new OutputFile($destname, - "${destname}_comb.c"); - my @tmp = stat($combFile); - my $combFileMtime = $tmp[9] || 0; - foreach my $mrg (@{$tomerge}) { - my @tmp = stat($mrg); my $mtime = $tmp[9]; - if($mtime >= $combFileMtime) { goto DoMerge; } - } - if($self->{VERBOSE}) { - print STDERR "Reusing merged file $combFile\n"; - } - $self->applyCilAndCompile([$combFile], $mergedobj, $ppargs, $ccargs); - } else { - DoMerge: - $self->applyCilAndCompile($tomerge, $mergedobj, $ppargs, $ccargs); - } - - # Put the merged OBJ at the beginning because maybe some of the trueobjs - # are libraries which like to be at the end - unshift @{$trueobjs}, $mergedobj; - - # And finally link - # zf: hack for linking linux stuff - if ($self->{TRUELIB}) { - my @cmd = (@{$self->{LDLIB}}, ($dest), - @{$ppargs}, @{$ccargs}, @{$trueobjs}, @{$ldargs}); - return $self->runShell(@cmd); - } - - # sm: hack: made this conditional for dsw - if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { - $self->link_after_cil($trueobjs, $dest, $ppargs, $ccargs, $ldargs); - } - -} - -sub applyCil { - my ($self, $ppsrc, $dest) = @_; - - # The input files - my @srcs = @{$ppsrc}; - - # Now prepare the command line for invoking cilly - my ($aftercil, @cmd) = $self->CillyCommand ($ppsrc, $dest); - Carp::confess "$self produced bad output file: $aftercil" - unless $aftercil->isa('OutputFile'); - - if($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB") { - push @cmd, '--MSVC'; - } - if($self->{VERBOSE}) { - push @cmd, '--verbose'; - } - if(defined $self->{CILARGS}) { - push @cmd, @{$self->{CILARGS}}; - } - - # Add the arguments - if(@srcs > 20) { - my $extraFile = "___extra_files"; - open(TOMERGE, ">$extraFile") || die $!; - foreach my $fl (@srcs) { - my $fname = ref $fl ? $fl->filename : $fl; - print TOMERGE "$fname\n"; - } - close(TOMERGE); - push @cmd, '--extrafiles', $extraFile; - } else { - push @cmd, @srcs; - } - if(@srcs > 1 && $self->{KEEPMERGED}) { - my ($base, $dir, undef) = fileparse($dest->filename, qr{\.[^.]+}); - push @cmd, '--mergedout', "$dir$base" . '.c'; - } - # Now run cilly - $self->runShell(@cmd); - - # Tell the caller where we put the output - return $aftercil; -} - - -sub applyCilAndCompile { - my ($self, $ppsrc, $dest, $ppargs, $ccargs) = @_; - Carp::confess "$self produced bad destination file: $dest" - unless $dest->isa('OutputFile'); - - # The input files - my @srcs = @{$ppsrc}; - &mydebug("Cilly.PM.applyCilAndCompile(srcs=[",join(',',@{$ppsrc}),"])\n"); - - # Now run cilly - my $aftercil = $self->applyCil($ppsrc, $dest); - Carp::confess "$self produced bad output file: $aftercil" - unless $aftercil->isa('OutputFile'); - - # Now preprocess - my $aftercilpp = $self->preprocessAfterOutputFile($aftercil); - $self->preprocess_after_cil($aftercil, $aftercilpp, $ppargs); - - if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) { - # Now compile - return $self->compile_cil($aftercilpp, $dest, $ppargs, $ccargs); - } -} - -# Linking after CIL -sub link_after_cil { - my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; - if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) { - return $self->straight_link($psrcs, $dest, $ppargs, $ccargs, $ldargs); - } -} - -# See if we must merge this one -sub leaveAlone { - my($self, $filename) = @_; - my ($base, $dir, $ext) = fileparse($filename, "(\\.[^.]+)"); - if(grep { $_ eq $base } @{$self->{LEAVEALONE}}) { - return 1; - } else { - return 0; - } -} - - -# DO EVERYTHING -sub doit { - my ($self) = @_; - my $file; - my $out; - -# print Dumper($self); - - # Maybe we must preprocess only - if($self->{OPERATION} eq "TOI" || $self->{OPERATION} eq 'SPECIAL') { - # Then we do not do anything - my @cmd = (@{$self->{CPP}}, - @{$self->{EARLY_PPARGS}}, - @{$self->{PPARGS}}, @{$self->{CCARGS}}, - @{$self->{CFILES}}, @{$self->{SFILES}}); - push @cmd, @{$self->{OUTARG}} if defined $self->{OUTARG}; - - return $self->runShell(@cmd); - } - # We expand some libraries names. Maybe they just contain some - # new object files - $self->expandLibraries(); - - # Try to guess whether to run in the separate mode. In that case - # we can go ahead with the compilation, without having to save - # files - if(! $self->{SEPARATE} && # Not already separate mode - $self->{OPERATION} eq "TOEXE" && # We are linking to an executable - @{$self->{CFILES}} + @{$self->{IFILES}} <= 1) { # At most one source - # If we have object files, we should keep merging if at least one - # object file is a disguised source - my $turnOffMerging = 0; - if(@{$self->{OFILES}}) { - my ($tomerge, $trueobjs, $mergedccargs) = - $self->separateTrueObjects($self->{OFILES}, $self->{CCARGS}); - $self->{CCARGS} = $mergedccargs; - $turnOffMerging = (@{$tomerge} == 0); - } else { - $turnOffMerging = 1; - } - if($turnOffMerging) { - if($self->{VERBOSE}) { - print STDERR - "Turn off merging because the program contains one file\n"; - } - $self->{SEPARATE} = 1; - } - } - - # Turn everything into OBJ files - my @tolink = (); - - foreach $file (@{$self->{IFILES}}, @{$self->{CFILES}}) { - $out = $self->compileOutputFile($file); - $self->preprocess_compile($file, $out, - $self->{EARLY_PPARGS}, - $self->{PPARGS}, $self->{CCARGS}); - push @tolink, $out; - } - # Now do the assembly language file - foreach $file (@{$self->{SFILES}}) { - $out = $self->assembleOutputFile($file); - $self->assemble($file, $out, $self->{PPARGS}, $self->{CCARGS}); - push @tolink, $out; - } - # Now add the original object files. Put them last because libraries like - # to be last. - push @tolink, @{$self->{OFILES}}; - - # See if we must stop after compilation - if($self->{OPERATION} eq "TOOBJ") { - return; - } - - # See if we must create a library only - if($self->{OPERATION} eq "TOLIB") { - if (!$self->{TRUELIB}) { - # zf: Creating a library containing merged source - $out = $self->linkOutputFile(@tolink); - $self->linktolib(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, - $self->{LINKARGS}); - return; - } else { - # zf: Linking to a true library. Do real curing. - # Only difference from TOEXE is that we use "partial linking" of the - # underlying linker - if ($self->{VERBOSE}) { - print STDERR "Linking to a true library!"; - } - push @{$self->{CCARGS}}, "-r"; - $out = $self->linkOutputFile(@tolink); - $self->link(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); - return; - } - - } - - # Now link all of the files into an executable - if($self->{OPERATION} eq "TOEXE") { - $out = $self->linkOutputFile(@tolink); - $self->link(\@tolink, $out, - $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); - return; - } - - die "I don't understand OPERATION:$self->{OPERATION}\n"; -} - -sub classifyArgDebug { - if(0) { print @_; } -} - -sub mydebug { - if(0) { print @_; } -} - -sub compilerArgument { - my($self, $options, $arg, $pargs) = @_; - &classifyArgDebug("Classifying arg: $arg\n"); - my $idx = 0; - for($idx=0; $idx < $#$options; $idx += 2) { - my $key = ${$options}[$idx]; - my $action = ${$options}[$idx + 1]; - &classifyArgDebug("Try match with $key\n"); - if($arg =~ m|^$key|) { - &classifyArgDebug(" match with $key\n"); - my @fullarg = ($arg); - my $onemore; - if(defined $action->{'ONEMORE'}) { - &classifyArgDebug(" expecting one more\n"); - # Maybe the next arg is attached - my $realarg; - ($realarg, $onemore) = ($arg =~ m|^($key)(.+)$|); - if(! defined $onemore) { - # Grab the next argument - $onemore = $self->fetchNextArg($pargs); - $onemore = "eIfNecessary($onemore); - push @fullarg, $onemore; - } else { - $onemore = "eIfNecessary($onemore); - } - &classifyArgDebug(" onemore=$onemore\n"); - } - # Now see what action we must perform - my $argument_done = 1; - if(defined $action->{'RUN'}) { - &{$action->{'RUN'}}($self, @fullarg, $onemore, $pargs); - $argument_done = 1; - } - # Quote special SHELL caracters - @fullarg = map { $_ =~ s%([<>;&|])%'$1'%g; $_ } @fullarg; - # print "fullarg = ", @fullarg, "\n"; - if(defined $action->{'TYPE'}) { - &classifyArgDebug(" type=$action->{TYPE}\n"); - if($action->{TYPE} eq 'EARLY_PREPROC') { - push @{$self->{EARLY_PPARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "PREPROC") { - push @{$self->{PPARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq 'SPECIAL') { - push @{$self->{PPARGS}}, @fullarg; - $self->{OPERATION} = 'SPECIAL'; - return 1; - } - elsif($action->{TYPE} eq "CC") { - push @{$self->{CCARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "LINKCC") { - push @{$self->{CCARGS}}, @fullarg; - push @{$self->{LINKARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "ALLARGS") { - push @{$self->{PPARGS}}, @fullarg; - push @{$self->{CCARGS}}, @fullarg; - push @{$self->{LINKARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "LINK") { - push @{$self->{LINKARGS}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "CSOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{CFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "ASMSOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{SFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "OSOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{OFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq "ISOURCE") { - OutputFile->protect(@fullarg); - $fullarg[0] = &normalizeFileName($fullarg[0]); - push @{$self->{IFILES}}, @fullarg; return 1; - } - elsif($action->{TYPE} eq 'OUT') { - if(defined($self->{OUTARG})) { - print "Warning: output file is multiply defined: @{$self->{OUTARG}} and @fullarg\n"; - } - $fullarg[0] = &normalizeFileName($fullarg[0]); - $self->{OUTARG} = [@fullarg]; return 1; - } - print " Do not understand TYPE\n"; return 1; - } - if($argument_done) { return 1; } - print "Don't know what to do with option $arg\n"; - return 0; - } - } - return 0; -} - - -sub runShell { - my ($self, @cmd) = @_; - - my $msvcFriends = - ($self->{MODENAME} eq "MSVC" || - $self->{MODENAME} eq "MSLINK" || - $self->{MODENAME} eq "MSLIB"); - - foreach (@cmd) { - $_ = $_->filename if ref; - # If we are in MSVC mode then we might have to convert the files - # from cygwin names to the actual Windows names - if($msvcFriends && $^O eq "cygwin") { - my $arg = $_; - if ($arg =~ m|^/| && -f $arg) { - my $mname = `cygpath -m $arg`; - chop $mname; - if($mname ne "") { $_ = $mname; } - } - } - } - - # sm: I want this printed to stderr instead of stdout - # because the rest of 'make' output goes there and this - # way I can capture to a coherent file - # sm: removed conditional on verbose since there's already - # so much noise in the output, and this is the *one* piece - # of information I *always* end up digging around for.. - if($self->{TRACE_COMMANDS}) { print STDERR "@cmd\n"; } - - # weimer: let's have a sanity check - my $code = system { $cmd[0] } @cmd; - if ($code != 0) { - # sm: now that we always print, don't echo the command again, - # since that makes the output more confusing - #die "Possible error with @cmd!\n"; - $code >>= 8; # extract exit code portion - - exit $code; - } - return $code; -} - -sub quoteIfNecessary { - my($arg) = @_; - # If it contains spaces or "" then it must be quoted - if($arg =~ m|\s| || $arg =~ m|\"|) { - return "\'$arg\'"; - } else { - return $arg; - } -} - - -sub cilOutputFile { - Carp::croak 'bad argument count' unless @_ == 3; - my ($self, $basis, $suffix) = @_; - - if (defined $self->{SAVE_TEMPS}) { - return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS}); - } else { - return $self->outputFile($basis, $suffix); - } -} - - -sub outputFile { - Carp::confess 'bad argument count' unless @_ == 3; - my ($self, $basis, $suffix) = @_; - - if (defined $self->{SAVE_TEMPS}) { - return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS}); - } else { - return new TempFile($basis, $suffix); - } -} - - -########################################################################### -#### -#### MS CL specific code -#### -package MSVC; - -use strict; -use File::Basename; -use Data::Dumper; - -# For MSVC we remember which was the first source, because we use that to -# determine the name of the output file -sub setFirstSource { - my ($self, $src) = @_; - - if(! defined ($self->{FIRST_SOURCE})) { - $self->{FIRST_SOURCE} = $src; - } -} - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - # Create $self - - my $self = - { NAME => 'Microsoft cl compiler', - MODENAME => 'MSVC', - CC => ['cl', '/nologo', '/D_MSVC', '/c'], - CPP => ['cl', '/nologo', '/D_MSVC', '/P'], - LD => ['cl', '/nologo', '/D_MSVC'], - DEFARG => "/D", - INCARG => "/I", - DEBUGARG => ['/Zi', '/MLd', '/DEBUG'], - OPTIMARG => ['/Ox', '/G6'], - OBJEXT => "obj", - LIBEXT => "lib", # Library extension (without the .) - EXEEXT => ".exe", # Executable extension (with the .) - OUTOBJ => "/Fo", - OUTEXE => "/Fe", - WARNISERROR => "/WX", - FORCECSOURCE => ['/Tc'], - LINEPATTERN => "^#line\\s+(\\d+)\\s+\"(.+)\"", - - OPTIONS => -# Describe the compiler options as a list of patterns and associated actions. -# The patterns are matched in order against the _begining_ of the argument. -# -# If the action contains ONEMORE => 1 then the argument is expected to be -# parameterized by a following word. The word can be attached immediately to -# the end of the argument or in a separate word. -# -# If the action contains TYPE => "..." then the argument is put into -# one of several lists, as follows: "PREPROC" in ppargs; "CC" in -# ccargs; "LINK" in linkargs; "LINKCC" both in ccargs and linkargs; -# "ALLARGS" in ppargs, ccargs, and linkargs; "CSOURCE" in cfiles; -# "ASMSOURCE" in sfiles; "OSOURCE" in ofiles; "ISOURCE" in ifiles; -# "OUT" in outarg. "SPECIAL" flags indicate that the compiler should -# be run directly so that it can perform some special action other -# than generating code (e.g. printing out version or configuration -# information). -# -# If the TYPE is not defined but the RUN => sub { ... } is defined then the -# given subroutine is invoked with the self, the argument and the (possibly -# empty) additional word and a pointer to the list of remaining arguments -# - ["^[^/\\-@].*\\.($::cilbin|c|cpp|cc)\$" => - { TYPE => 'CSOURCE', - RUN => sub { &MSVC::setFirstSource(@_); } }, - "[^/].*\\.(asm)\$" => { TYPE => 'ASMSOURCE' }, - "[^/].*\\.i\$" => { TYPE => 'ISOURCE' }, - "[^/\\-@]" => { TYPE => "OSOURCE" }, - "[/\\-]O" => { TYPE => "CC" }, - "[/\\-][DI]" => { TYPE => "PREPROC"}, - "[/\\-]EH" => { TYPE => "CC" }, - "[/\\-]G" => { TYPE => "CC" }, - "[/\\-]F[aA]" => { TYPE => 'CC' }, - "[/\\-]Fo" => { TYPE => 'OUT' }, - "/Fe" => { TYPE => 'OUT', - RUN => sub { $stub->{OPERATION} = "TOEXE" }}, - "[/\\-]F[dprR]" => { TYPE => "CC" }, - "[/\\-]FI" => { TYPE => "PREPROC" }, - "[/\\-][CXu]" => { TYPE => "PREPROC" }, - "[/\\-]U" => { ONEMORE => 1, TYPE => "PREPROC" }, - "[/\\-](E|EP|P)" => { RUN => sub { push @{$stub->{PPARGS}}, $_[1]; - $stub->{OPERATION} = "PREPROC"; }}, - "[/\\-]c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, - "[/\\-](Q|Z|J|nologo|w|W|Zm)" => { TYPE => "CC" }, - "[/\\-]Y(u|c|d|l|X)" => { TYPE => "CC" }, - "[/\\-]T(C|P)" => { TYPE => "PREPROC" }, - "[/\\-]Tc(.+)\$" => - { RUN => sub { - my $arg = $_[1]; - my ($fname) = ($arg =~ m|[/\\-]Tc(.+)$|); - $fname = &normalizeFileName($fname); - push @{$stub->{CFILES}}, $fname; - }}, - "[/\\-]v(d|m)" => { TYPE => "CC" }, - "[/\\-]F" => { TYPE => "CC" }, - "[/\\-]M" => { TYPE => 'LINKCC' }, - "/link" => { RUN => sub { push @{$stub->{LINKARGS}}, "/link", - @{$_[3]}; - @{$_[3]} = (); } }, - "-cbstring" => { TYPE => "CC" }, - "/" => { RUN => - sub { print "Unimplemented MSVC argument $_[1]\n";}}, - ], - }; - bless $self, $class; - return $self; -} - - -sub msvc_preprocess { - my($self, $src, $dest, $ppargs) = @_; - my $res; - my $srcname = ref $src ? $src->filename : $src; - my ($sbase, $sdir, $sext) = - fileparse($srcname, - "(\\.c)|(\\.cc)|(\\.cpp)|(\\.i)"); - # If this is a .cpp file we still hope it is C. Pass the /Tc argument to - # cl to force this file to be interpreted as a C one - my @cmd = @{$ppargs}; - - if($sext eq ".cpp") { - push @cmd, "/Tc"; - } - # MSVC cannot be told where to put the output. But we know that it - # puts it in the current directory - my $msvcout = "./$sbase.i"; - if($self->{STDOUTPP}) { - @cmd = ('cmd', '/c', 'cl', '/nologo', '/E', ">$msvcout", '/D_MSVC', - @cmd); - - } else { - @cmd = ('cl', '/nologo', '/P', '/D_MSVC', @cmd); - } - $res = $self->runShell(@cmd, $srcname); - # Check file equivalence by making sure that all elements of the stat - # structure are the same, except for the access time. - my @st1 = stat $msvcout; $st1[8] = 0; - my @st2 = stat $dest->{filename}; $st2[8] = 0; - # print Dumper(\@st1, \@st2); - if($msvcout ne $dest->{filename}) { - while($#st1 >= 0) { - if(shift @st1 != shift @st2) { -# print "$msvcout is NOT the same as $afterpp\n"; - if($self->{VERBOSE}) { - print STDERR "Copying $msvcout to $dest->{filename} (MSVC_preprocess)\n"; - } - unlink $dest; - File::Copy::copy($msvcout, $dest->filename); - unlink $msvcout; - return $res; - } - } - } - return $res; -} - -sub forceIncludeArg { - my($self, $what) = @_; - return "/FI$what"; -} - - - # MSVC does not understand the extension .i, so we tell it it is a C file -sub fixupCsources { - my (@csources) = @_; - my @mod_csources = (); - my $src; - foreach $src (@csources) { - my ($sbase, $sdir, $sext) = fileparse($src, - "\\.[^.]+"); - if($sext eq ".i") { - push @mod_csources, "/Tc"; - } - push @mod_csources, $src; - } - return @mod_csources; -} - - -# Emit a line # directive -sub lineDirective { - my ($self, $fileName, $lineno) = @_; - return "#line $lineno \"$fileName\"\n"; -} - -# The name of the output file -sub compileOutputFile { - my($self, $src) = @_; - - die "compileOutputFile: not a C source file: $src\n" - unless $src =~ /\.($::cilbin|c|cc|cpp|i|asm)$/; - - Carp::carp ("compileOutputFile: $self->{OPERATION}, $src", - Dumper($self->{OUTARG})) if 0; - if ($self->{OPERATION} eq 'TOOBJ') { - if(defined $self->{OUTARG} - && "@{$self->{OUTARG}}" =~ m|[/\\-]Fo(.+)|) { - my $dest = $1; - # Perhaps $dest is a directory - if(-d $dest) { - return new KeptFile($src, $self->{OBJEXT}, $dest); - } else { - return new OutputFile($src, $1); - } - } else { - return new KeptFile($src, $self->{OBJEXT}, '.'); - } - } else { -# die "compileOutputfile: operation is not TOOBJ"; - return $self->outputFile($src, $self->{OBJEXT}); - } -} - -sub assembleOutputFile { - my($self, $src) = @_; - return $self->compileOutputFile($src); -} - -sub linkOutputFile { - my($self, $src) = @_; - $src = $src->filename if ref $src; - if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|/Fe(.+)|) { - return $1; - } - # Use the name of the first source file, in the current directory - my ($base, $dir, $ext) = fileparse ($src, "\\.[^.]+"); - return "./$base.exe"; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "cl 2>&1|") || die "Cannot start Microsoft CL\n"; - while() { - if($_ =~ m|Compiler Version (\S+) |) { - $cversion = "cl_$1"; - close(VER); - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find Microsoft CL version\n"; -} - -######################################################################## -## -## MS LINK specific code -## -### -package MSLINK; - -use strict; - -use File::Basename; -use Data::Dumper; - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - - # Create a MSVC compiler object - my $msvc = MSVC->new($stub); - - # Create $self - - my $self = - { NAME => 'Microsoft linker', - MODENAME => 'MSLINK', - CC => $msvc->{CC}, - CPP => $msvc->{CPP}, - LD => ['link'], - DEFARG => $msvc->{DEFARG}, - INCARG => $msvc->{INCARG}, - DEBUGARG => ['/DEBUG'], - OPTIMARG => [], - LDLIB => ['lib'], - OBJEXT => "obj", - LIBEXT => "lib", # Library extension (without the .) - EXEEXT => ".exe", # Executable extension (with the .) - OUTOBJ => $msvc->{OUTOBJ}, - OUTEXE => "-out:", # Keep this form because build.exe looks for it - WARNISERROR => "/WX", - LINEPATTERN => "", - FORCECSOURCE => $msvc->{FORCECSOURCE}, - - MSVC => $msvc, - - OPTIONS => - ["[^/\\-@]" => { TYPE => 'OSOURCE' }, - "[/\\-](OUT|out):" => { TYPE => 'OUT' }, - "^((/)|(\\-[^\\-]))" => { TYPE => 'LINK' }, - ], - }; - bless $self, $class; - return $self; -} - - -sub forceIncludeArg { # Same as for CL - my($self, $what) = @_; - return "/FI$what"; -} - - - -sub linkOutputFile { - my($self, $src) = @_; -# print Dumper($self); - Carp::confess "Cannot compute the linker output file" - if ! defined $self->{OUTARG}; - - if("@{$self->{OUTARG}}" =~ m|.+:(.+)|) { - return $1; - } - die "I do not know what is the link output file\n"; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "link 2>&1|") || die "Cannot start Microsoft LINK\n"; - while() { - if($_ =~ m|Linker Version (\S+)|) { - $cversion = "link_$1"; - close(VER); - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find Microsoft LINK version\n"; -} - -######################################################################## -## -## MS LIB specific code -## -### -package MSLIB; - -our @ISA = qw(MSLINK); - -use strict; - -use File::Basename; -use Data::Dumper; - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - - # Create a MSVC linker object - my $self = MSLINK->new($stub); - - $self->{NAME} = 'Microsoft librarian'; - $self->{MODENAME} = 'MSLIB'; - $self->{OPERATION} = "TOLIB"; - $self->{LDLIB} = ['lib']; - bless $self, $class; - return $self; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "lib 2>&1|") || die "Cannot start Microsoft LIB\n"; - while() { - if($_ =~ m|Library Manager Version (\S+)|) { - $cversion = "lib_$1"; - close(VER); - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find Microsoft LINK version\n"; -} - -######################################################################## -## -## GNU ar specific code -## -### -package AR; - -use strict; - -use File::Basename; -use Data::Dumper; - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - # Create $self - - my $self = - { NAME => 'Archiver', - MODENAME => 'ar', - CC => ['no_compiler_in_ar_mode'], - CPP => ['no_compiler_in_ar_mode'], - LDLIB => ['ar', 'crv'], - DEFARG => "??DEFARG", - INCARG => '??INCARG', - DEBUGARG => ['??DEBUGARG'], - OPTIMARG => [], - OBJEXT => "o", - LIBEXT => "a", # Library extension (without the .) - EXEEXT => "", # Executable extension (with the .) - OUTOBJ => "??OUTOBJ", - OUTLIB => "", # But better be first - LINEPATTERN => "", - - OPTIONS => - ["^[^-]" => { RUN => \&arArguments } ] - - }; - bless $self, $class; - return $self; -} - -# We handle arguments in a special way for AR -sub arArguments { - my ($self, $arg, $onemore, $pargs) = @_; - # If the first argument starts with -- pass it on - if($arg =~ m|^--|) { - return 0; - } - # We got here for the first non -- argument. - # Will handle all arguments at once - if($self->{VERBOSE}) { - print "AR called with $arg @{$pargs}\n"; - } - - #The r flag is required: - if($arg !~ m|r| || $#{$pargs} < 0) { - die "Error: CCured's AR mode implements only the r and cr operations."; - } - if($arg =~ /[^crvus]/) { - die "Error: CCured's AR mode supports only the c, r, u, s, and v flags."; - } - if($arg =~ /v/) { - $self->{VERBOSE} = 1; - } - - if($arg =~ /c/) - { - # Command is "cr": - # Get the name of the library - my $out = shift @{$pargs}; - $self->{OUTARG} = [$out]; - unlink $out; - } - else - { - # if the command is "r" alone, we should add to the current library, - # not replace it, unless the library does not exist - - # Get the name of the library - my $out = shift @{$pargs}; - $self->{OUTARG} = [$out]; - - #The library is both an input and an output. - #To avoid problems with reading and writing the same file, move the - #current version of the library out of the way first. - if(-f $out) { - - my $temp_name = $out . "_old.a"; - if($self->{VERBOSE}) { - print "Copying $out to $temp_name so we can add " - . "to it.\n"; - } - if(-f $temp_name) { - unlink $temp_name; - } - rename $out, $temp_name; - - #now use $temp_name as the input. $self->{OUTARG} will, - # as usual, be the output. - push @{$self->{OFILES}}, $temp_name; - } else { - warn "Library $out not found; creating."; - } - - } - - # The rest of the arguments must be object files - push @{$self->{OFILES}}, @{$pargs}; - $self->{OPERATION} = 'TOLIB'; - @{$pargs} = (); -# print Dumper($self); - return 1; -} - -sub linkOutputFile { - my($self, $src) = @_; - if(defined $self->{OUTARG}) { - return "@{$self->{OUTARG}}"; - } - die "I do not know what is the link output file\n"; -} - -sub setVersion { - # sm: bin/cilly wants this for all "compilers" -} - - -######################################################################### -## -## GNUCC specific code -## -package GNUCC; - -use strict; - -use File::Basename; - -# The variable $::cc is inherited from the main script!! - -sub new { - my ($proto, $stub) = @_; - my $class = ref($proto) || $proto; - # Create $self - - my @native_cc = Text::ParseWords::shellwords($ENV{CILLY_NATIVE_CC} || $::cc); - - my $self = - { NAME => 'GNU CC', - MODENAME => 'GNUCC', # do not change this since it is used in code - # sm: added -O since it's needed for inlines to be merged instead of causing link errors - # sm: removed -O to ease debugging; will address "inline extern" elsewhere - CC => [@native_cc, '-D_GNUCC', '-c'], - LD => [@native_cc, '-D_GNUCC'], - LDLIB => ['ld', '-r', '-o'], - CPP => [@native_cc, '-D_GNUCC', '-E'], - DEFARG => "-D", - INCARG => "-I", - DEBUGARG => ['-g', '-ggdb'], - OPTIMARG => ['-O4'], - CPROFILEARG => '-pg', - LPROFILEARG => '-pg', - OBJEXT => "o", - LIBEXT => "a", - EXEEXT => "", - OUTOBJ => '-o', - OUTEXE => '-o', - OUTCPP => '-o', - WARNISERROR => "-Werror", - FORCECSOURCE => [], - LINEPATTERN => "^#\\s+(\\d+)\\s+\"(.+)\"", - - OPTIONS => - [ "[^-].*\\.($::cilbin|c|cpp|cc)\$" => { TYPE => 'CSOURCE' }, - "[^-].*\\.(s|S)\$" => { TYPE => 'ASMSOURCE' }, - "[^-].*\\.i\$" => { TYPE => 'ISOURCE' }, - # .o files can be linker scripts - "[^-]" => { RUN => sub { &GNUCC::parseLinkerScript(@_); }}, - "-E" => { RUN => sub { $stub->{OPERATION} = "TOI"; }}, - "-pipe\$" => { TYPE => 'ALLARGS' }, - "-[DIU]" => { ONEMORE => 1, TYPE => "PREPROC" }, - "-isystem" => { ONEMORE => 1, TYPE => "PREPROC" }, - '-undef$' => { TYPE => 'PREPROC' }, - '-w$' => { TYPE => 'PREPROC' }, - '-M$' => { TYPE => 'SPECIAL' }, - '-MM$' => { TYPE => 'SPECIAL' }, - '-MF$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, - '-C$' => { TYPE => 'EARLY_PREPROC'}, # zra - '-MG$' => { TYPE => 'EARLY_PREPROC' }, - '-MP$' => { TYPE => 'EARLY_PREPROC' }, - '-MT$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, - '-MQ$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, - '-MD$' => { TYPE => 'EARLY_PREPROC' }, - '-MMD$' => { TYPE => 'EARLY_PREPROC' }, - "-include" => { ONEMORE => 1, TYPE => "PREPROC" }, # sm - "-iwithprefix" => { ONEMORE => 1, TYPE => "PREPROC" }, - '-Wp,' => { TYPE => 'PREPROC' }, - "-ansi" => { TYPE => 'ALLARGS' }, - "-c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, - "-x" => { ONEMORE => 1, TYPE => "CC" }, - "-v" => { TYPE => 'ALLARGS', - RUN => sub { $stub->{TRACE_COMMANDS} = 1; } }, - "^-e\$" => { ONEMORE => 1, TYPE => 'LINK' }, - "^-T\$" => { ONEMORE => 1, TYPE => 'LINK' }, - # GCC defines some more macros if the optimization is On so pass - # the -O to the preprocessor and the compiler - '-O' => { TYPE => 'ALLARGS' }, - "-S" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; - push @{$stub->{CCARGS}}, $_[1]; }}, - "-o" => { ONEMORE => 1, TYPE => 'OUT' }, - "-p\$" => { TYPE => 'LINKCC' }, - "-pg" => { TYPE => 'LINKCC' }, - "-a" => { TYPE => 'LINKCC' }, - "-pedantic\$" => { TYPE => 'ALLARGS' }, - "-Wall" => { TYPE => 'CC', - RUN => sub { push @{$stub->{CILARGS}},"--warnall";}}, - "-W[-a-z]*\$" => { TYPE => 'CC' }, - '-g' => { TYPE => 'ALLARGS' }, - "-save-temps" => { TYPE => 'ALLARGS', - RUN => sub { if(! defined $stub->{SAVE_TEMPS}) { - $stub->{SAVE_TEMPS} = '.'; } }}, - '--?print-' => { TYPE => 'SPECIAL' }, - '-dump' => { TYPE => 'SPECIAL' }, - "-l" => - { RUN => sub { - my ($libname) = ($_[1] =~ m|-l(.+)$|); - # See if we can find this library in the LIBDIR - my @libdirs = @{$stub->{LIBDIR}}; - if($#libdirs == -1) { - push @libdirs, '.'; - } - foreach my $d (@libdirs) { - if(-f "$d/lib$libname.a") { - # Pretend that we had a straight argument - push @{$stub->{OFILES}}, "$d/lib$libname.a"; - return; - } - } - # We get here when we cannot find the library in the LIBDIR - push @{$stub->{LINKARGS}}, $_[1]; - }}, - "-L" => - { RUN => sub { - # Remember these directories in LIBDIR - my ($dir) = ($_[1] =~ m|-L(.+)$|); - push @{$stub->{LIBDIR}}, $dir; - push @{$stub->{LINKARGS}}, $_[1]; - }}, - "-f" => { TYPE => 'LINKCC' }, - "-r\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }}, - "-i\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }}, - "-m" => { TYPE => 'LINKCC', ONEMORE => 1 }, - "-s\$" => { TYPE => 'LINKCC' }, - "-Xlinker" => { ONEMORE => 1, TYPE => 'LINK' }, - "-nostdlib" => { TYPE => 'LINK' }, - "-nostdinc" => { TYPE => 'PREPROC' }, - '-rdynamic$' => { TYPE => 'LINK' }, - "-static" => { TYPE => 'LINK' }, - "-shared" => { TYPE => 'LINK' }, - "-static-libgcc" => { TYPE => 'LINK' }, - "-shared-libgcc" => { TYPE => 'LINK' }, - '-Wl,--(no-)?whole-archive$' => { TYPE => 'OSOURCE' }, - '-Wl,' => { TYPE => 'LINK' }, - "-traditional" => { TYPE => 'PREPROC' }, - '-std=' => { TYPE => 'ALLARGS' }, - "--start-group" => { RUN => sub { } }, - "--end-group" => { RUN => sub { }}, - "-pthread\$" => { TYPE => 'ALLARGS' }, - ], - - }; - bless $self, $class; - return $self; -} -# ' - -my $linker_script_debug = 0; -sub parseLinkerScript { - my($self, $filename, $onemore, $pargs) = @_; - - if(! defined($self->{FLATTEN_LINKER_SCRIPTS}) || - $filename !~ /\.o$/) { - NotAScript: - warn "$filename is not a linker script\n" if $linker_script_debug; - push @{$self->{OFILES}}, $filename; - return 1; - } - warn "parsing OBJECT FILE:$filename ****************\n" if - $linker_script_debug; - open OBJFILE, $filename or die $!; - my $line = ; - if ($line !~ /^INPUT/) { - close OBJFILE or die $!; - goto NotAScript; - } - warn "\tYES an INPUT file.\n" if $linker_script_debug; - my @lines = ; # Read it all and close it - unshift @lines, $line; - close OBJFILE or die $!; - # Process recursively each line from the file - my @tokens = (); - my $incomment = 0; # Whether we are in a comment - foreach my $line (@lines) { - chomp $line; - if($incomment) { - # See where the comment ends - my $endcomment = index($line, "*/"); - if($endcomment < 0) { # No end on this line - next; # next line - } else { - $line = substr($line, $endcomment + 2); - $incomment = 0; - } - } - # Drop the comments that are on a single line - $line =~ s|/\*.*\*/| |g; - # Here if outside comment. See if a comment starts - my $startcomment = index($line, "/*"); - if($startcomment >= 0) { - $incomment = 1; - $line = substr($line, 0, $startcomment); - } - # Split the line into tokens. Sicne we use parentheses in the pattern - # the separators will be tokens as well - push @tokens, split(/([(),\s])/, $line); - } - print "Found tokens:", join(':', @tokens), "\n" - if $linker_script_debug; - # Now parse the file - my $state = 0; - foreach my $token (@tokens) { - if($token eq "" || $token =~ /\s+/) { next; } # Skip spaces - if($state == 0) { - if($token eq "INPUT") { $state = 1; next; } - else { die "Error in script: expecting INPUT"; } - } - if($state == 1) { - if($token eq "(") { $state = 2; next; } - else { die "Error in script: expecting ( after INPUT"; } - } - if($state == 2) { - if($token eq ")") { $state = 0; next; } - if($token eq ",") { next; } # Comma could be a separator - # Now we better see a filename - if(! -f $token) { - warn "Linker script mentions inexistent file:$token.Ignoring\n"; - next; - } - # Process it recursively because it could be a script itself - warn "LISTED FILE:$token.\n" if $linker_script_debug; - $self->parseLinkerScript($token, $onemore, $pargs); - next; - } - die "Invalid linker script parser state\n"; - - } -} - -sub forceIncludeArg { - my($self, $what) = @_; - return ('-include', $what); -} - - -# Emit a line # directive -sub lineDirective { - my ($self, $fileName, $lineno) = @_; - return "# $lineno \"$fileName\"\n"; -} - -# The name of the output file -sub compileOutputFile { - my($self, $src) = @_; - - die "objectOutputFile: not a C source file: $src\n" - unless $src =~ /\.($::cilbin|c|cc|cpp|i|s|S)$/; - - if ($self->{OPERATION} eq 'TOOBJ') { - if (defined $self->{OUTARG} - && "@{$self->{OUTARG}}" =~ m|^-o\s*(\S.+)$|) { - return new OutputFile($src, $1); - } else { - return new KeptFile($src, $self->{OBJEXT}, '.'); - } - } else { - return $self->outputFile($src, $self->{OBJEXT}); - } -} - -sub assembleOutputFile { - my($self, $src) = @_; - return $self->compileOutputFile($src); -} - -sub linkOutputFile { - my($self, $src) = @_; - if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|-o\s*(\S.+)|) { - return $1; - } - return "a.out"; -} - -sub setVersion { - my($self) = @_; - my $cversion = ""; - open(VER, "@{$self->{CC}} -dumpversion " - . join(' ', @{$self->{PPARGS}}) ." |") - || die "Cannot start GNUCC"; - while() { - if($_ =~ m|^(\d+\S+)| || $_ =~ m|^(egcs-\d+\S+)|) { - $cversion = "gcc_$1"; - close(VER) || die "Cannot start GNUCC\n"; - $self->{VERSION} = $cversion; - return; - } - } - die "Cannot find GNUCC version\n"; -} - -1; - - -__END__ - - - diff --git a/cil/lib/KeptFile.pm b/cil/lib/KeptFile.pm deleted file mode 100644 index 904b514..0000000 --- a/cil/lib/KeptFile.pm +++ /dev/null @@ -1,88 +0,0 @@ -package KeptFile; -use OutputFile; -@ISA = (OutputFile); - -use strict; -use Carp; -use File::Basename; -use File::Spec; - - -######################################################################## - - -sub new { - croak 'bad argument count' unless @_ == 4; - my ($proto, $basis, $suffix, $dir) = @_; - my $class = ref($proto) || $proto; - - $basis = $basis->basis if ref $basis; - my ($basename, undef, $basefix) = fileparse($basis, qr{\.[^.]+}); - my $filename = File::Spec->catfile($dir, "$basename.$suffix"); - - my $self = $class->SUPER::new($basis, $filename); - return $self; -} - - -######################################################################## - - -1; - -__END__ - - -=head1 Name - -KeptFile - persistent compiler output files - -=head1 Synopsis - - use KeptFile; - - my $cppOut = new KeptFile ('code.c', 'i', '/output/directory'); - system 'cpp', 'code.c', '-o', $cppOut->filename; - -=head2 Description - -C represents an intermediate output file generated by some -stage of a C-based compiler that should be retained after -compilation. It is a concrete subclass of L. -Use C when the user has asked for intermediate files to be -retained, such as via gcc's C<-save-temps> flag. - -=head2 Public Methods - -=over - -=item new - -C constructs a new C -instance. The new file name is constructed using the base file name -of C<$basis> with its suffix replaced by C<$suffix> and its path given -by C<$dir>. For example, - - new KeptFile ('/foo/code.c', 'i', '/bar') - -yields a C with file name F. - -C<$basis> may be either absolute or relative; only the trailing file -name is used. C<$basis> can also be an C instance, in -which case C<< $basis->basis >> is used as the actual basis. See -L for more information on basis flattening. - -C<$suffix> should not include a leading dot; this will be added -automatically. - -C<$dir> may be either absolute or relative. It is common to use F<.> -as the directory, which puts the C in the current working -directory. - -=back - -=head1 See Also - -L, L. - -=cut diff --git a/cil/lib/OutputFile.pm b/cil/lib/OutputFile.pm deleted file mode 100644 index 8f02ba2..0000000 --- a/cil/lib/OutputFile.pm +++ /dev/null @@ -1,213 +0,0 @@ -package OutputFile; -@ISA = (); - -use strict; -use Carp; -use File::Basename; -use File::Spec; - - -######################################################################## - - -my $debug = 0; - - -sub new { - croak 'bad argument count' unless @_ == 3; - my ($proto, $basis, $filename) = @_; - my $class = ref($proto) || $proto; - - $basis = $basis->basis if ref $basis; - my $ref = { filename => $filename, - basis => $basis }; - my $self = bless $ref, $class; - - $self->checkRef($filename); - $self->checkRef($basis); - $self->checkProtected(); - $self->checkTemporary(); - - Carp::cluck "OutputFile: filename == $filename, basis == $basis" if $debug; - return $self; -} - - -sub filename { - my ($self) = @_; - return $self->{filename}; -} - - -sub basis { - my ($self) = @_; - return $self->{basis}; -} - - -######################################################################## - - -sub checkRef { - my ($self, $filename) = @_; - confess "ref found where string expected: $filename" if ref $filename; - confess "stringified ref found where string expected: $filename" if $filename =~ /\w+=HASH\(0x[0-9a-f]+\)/; -} - - -sub checkTemporary { - my ($self) = @_; - my ($basename, $path) = fileparse $self->filename; - return if $path eq File::Spec->tmpdir . '/'; - confess "found temporary file in wrong directory: ", $self->filename - if $basename =~ /^cil-[a-zA-Z0-9]{8}\./; -} - - -######################################################################## - - -my @protected = (); - - -sub checkProtected { - my ($self) = @_; - my $abs = File::Spec->rel2abs($self->filename); - - foreach (@protected) { - confess "caught attempt to overwrite protected file: ", $self->filename - if $_ eq $abs; - } -} - - -sub protect { - my ($self, @precious) = @_; - push @protected, File::Spec->rel2abs($_) - foreach @precious; -} - - -######################################################################## - - -1; - -__END__ - - -=head1 Name - -OutputFile - base class for intermediate compiler output files - -=head1 Description - -C represents an intermediate output file generated by some -stage of a C-based compiler. This is an abstract base class -and should never be instantiated directly. It provides common -behaviors used by concrete subclasses L and -L. - -=head2 Public Methods - -=over - -=item filename - -An C instance is a smart wrapper around a file name. C<< -$out->filename >> returns the name of the file represented by -C instance C<$out>. When building a command line, this is -the string to use for the file. For example: - - my $out = ... ; # some OutputFile subclass - my @argv = ('gcc', '-E', '-o', $out->filename, 'input.c'); - system @argv; - -C often creates command vectors with a mix of strings and -C objects. This is fine, but before using a mixed vector -as a command line, you must replace all C objects with -their corresponding file names: - - my @mixed = (...); # mix of strings and objects - my @normalized = @mixed; - $_ = (ref $_ ? $_->filename : $_) foreach @normalized; - system @normalized; - -Common utility methods like C already do exactly this -normalization, but you may need to do it yourself if you are running -external commands on your own. - -=item protect - -C contains safety interlocks that help it avoid stomping -on user input files. C<< OutputFile->protect($precious) >> marks -C<$precious> as a protected input file which should not be -overwritten. If any C tries to claim this same file name, -an error will be raised. In theory, this never happens. In practice, -scripts can have bugs, and it's better to be safe than sorry. - -C uses this method to register input files that it discovers -during command line processing. If you add special command line -processing of your own, or if you identify input files through other -means, we highly recommend using this method as well. Otherwise, -there is some risk that a buggy client script could mistakenly create -an output file that destroys the user's source code. - -Note that C is a class method: call it on the C -module, rather than on a specific instance. - -=back - -=head2 Internal Methods - -The following methods are used within C or by -C subclasses. They are not intended for use by outside -scripts. - -=over - -=item basis - -In addition to L, each C -instance records a second file name: its I. The basis file -name is initialized and used differently by different subclasses, but -typically represents the input file from which this output file is -derived. C<< $out->basis >> returns the basis file name for instance -C<$out>. - -When instantiating an C, the caller can provide either a -file name string as the basis or another C instance. -However, basis file names are not chained: if C<< $a->basis >> is -F, and C<$b> is constructed with C<$a> as its basis, C<< -$b->basis >> will return F, not C<$a> or C<< $a->filename >>. -This flattening is done at construction time. - -See L and L for more details on how -basis file names are used. - -=item checkRef - -C<< OutputFile->checkRef($filename) >> raises an error if C<$filename> -is an object reference, or looks like the string representation of an -object reference. Used to sanity check arguments to various methods. - -=item checkTemporary - -C<< $out->checkTemporary >> raises an error if C<< $out->filename >> -looks like a temporary file name but is not in the system temporary -directory. Used to sanity check arguments in various methods. - -=item checkProtected - -C<< $out->checkProtected >> raises an error if C<< $out->filename >> -is listed as a protected file. This check, performed at construction -time, implements a safety interlock to prevent overwriting of user -input files. Protected files are registered using L<"protect">. - -=back - -=head1 See Also - -L, L. - -=cut diff --git a/cil/lib/TempFile.pm b/cil/lib/TempFile.pm deleted file mode 100644 index 608713c..0000000 --- a/cil/lib/TempFile.pm +++ /dev/null @@ -1,90 +0,0 @@ -package TempFile; -use OutputFile; -@ISA = (OutputFile); - -use strict; -use Carp; -use File::Temp qw(tempfile); - - -######################################################################## - - -sub new { - croak 'bad argument count' unless @_ == 3; - my ($proto, $basis, $suffix) = @_; - my $class = ref($proto) || $proto; - - my (undef, $filename) = tempfile('cil-XXXXXXXX', - DIR => File::Spec->tmpdir, - SUFFIX => ".$suffix", - UNLINK => 1); - - my $self = $class->SUPER::new($basis, $filename); - return $self; -} - - -######################################################################## - - -1; - -__END__ - - -=head1 Name - -TempFile - transitory compiler output files - -=head1 Synopsis - - use TempFile; - - my $cppOut = new TempFile ('code.c', 'i'); - system 'cpp', 'code.c', '-o', $cppOut->filename; - -=head2 Description - -C represents an intermediate output file generated by some -stage of a C-based compiler that should be removed after -compilation. It is a concrete subclass of L. -Use C when the user has asked not for intermediate files to -be retained. - -All C files are removed when the script terminates. This -cleanup happens for both normal exits as well as fatal errors. -However, the standard L does not -perform cleanups, and therefore should be avoided in scripts that use -C. - -=head2 Public Methods - -=over - -=item new - -C constructs a new C -instance. The new file name is constructed in some system-specific -temporary directory with a randomly generated file name that ends with -C<$suffix>. For example, - - new TempFile ('/foo/code.c', 'i') - -might yield a C with file name F. - -C<$basis> gives the basis file name for this instance. The file name -is not used directly, but is retained in case this instance is later -passed as the basis for some other C. See -L for more information on basis flattening. - -C<$suffix> should not include a leading dot; this will be added -automatically. - -=back - -=head1 See Also - -L, L. - -=cut diff --git a/cil/ocamlutil/Makefile.ocaml b/cil/ocamlutil/Makefile.ocaml deleted file mode 100644 index 36ac21a..0000000 --- a/cil/ocamlutil/Makefile.ocaml +++ /dev/null @@ -1,395 +0,0 @@ -# -*- Mode: makefile -*- -# Copyright (c) 2001-2002, -# George C. Necula -# Scott McPeak -# Wes Weimer -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# 3. The names of the contributors may not be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - # Generic Makefile for Ocaml projects - # Written by necula@cs.berkeley.edu - # - # Features: - # - keeps byproducts of building in a separate directory - # - handles dependencies automatically - # - user specifies just what modules go into a project and - # everything else is done automatically - # - you can use one Makefile for several Ocaml projects - # - # You must include this file in your Makefile. Before the include point - # you must defined the following variables (which are glob al for all Ocaml - # projects specified in one Makefile): - # - # CAMLDIR - the directory where to get the ocaml executables from. - # Must be empty (defaul) or end with a / - # OBJDIR - the directory where to put all object files. This directory - # must exist (default obj) - # DEPENDDIR - the directory where to put dependency files. This directory - # must exist. (default obj/.depend) - # NATIVECAML - if set then will use the native compiler - # UNSAFE - if set then will turn off safety checks (only with NATIVECAML) - # PROFILE - if set then it will compile and link with "gprof" profiling - # support (NATIVECAML mode only) - # ASSEMBLY - if set then it will keep assembly files - # STATIC - if set then it will compile and link statically - # (NATIVECAML mode only) - # PREPROC - the preprocessor command - - # MODULES - a list of all modules for all projects defined in the - # Makefile. Give only the basenames (no directory, - # no extension). This is used to create the dependencies. - # SOURCEDIRS - a list of all directories containing sources for all - # projects defined in a Makefile. This is used to set vpath. - # MLLS - a list of all .mll (ocamllex input) files for all - # projects defined in the Makefile. - # MLYS - a list of all .mly (ocamlyacc input) files for all - # projects defined in the Makefile. - # ECHO - if specifically set to nothing then it will print - # all of the commands issued. Set this in the command line - # if you want to see what is going on. - # - # COMPILEFLAGS - if defined, then it is passed as argument to ocamlc - # and ocamlopt - # LINKFLAGS - if defined, then it is passed as argument to - # ocamlc and ocamlopt, when linking (at start of - # command line) - # - # CAML_CFLAGS - flags used only for the compilation of C files. - # e.g. '-ccopt ' - # - # - # After you set all of the above you must do the following for EACH separate - # executable that you want to build. - # - # Define the following: - # PROJECT_EXECUTABLE - the name of the executable you want to build. To take - # advantage of the naming scheme that separates the - # bytecode version and the native version, use the - # $(EXE) variable which is defined to either .byte.exe - # or .asm.exe. I typically put the executable in - # $(OBJDIR) as well. - # PROJECT_MODULES - the base names of the modules that make this - # executable in the order in which they must be - # passed to the linker. Make sure that all of - # the names mentioned here are also mentioned in - # MODULES. - # PROJECT_CMODULES - same as modules but for the C modules. These - # do not need to be mentioned in MODULES. There must be - # no name clashes with MODULES - # PROJECT_LIBS - the base names of the libraries that you - # want to link in the executable. - # - # - # Then include Makefile.ocaml.build to generate a customized - # rule for making your executable. - # - # Example: - # - # OBJDIR = obj - # DEPENDDIR = obj/.depend - # SOURCEDIRS = src src/special - # MLLS = mylex - # MLYS = myparse - # - # MODULES = mod11 mod12 mod21 modcommon - # - # # Rules for project 1 - # PROJECT_EXECUTABLE = $(OBJDIR)/proj1$(EXE) - # PROJECT_MODULES = mod11 mod12 modcommon - # PROJECT_CMODULES = - # PROJEC_LIBS = unix - # include Makefile.ocaml.build - # - # - # # Rules for project 2 - # PROJECT_EXECUTABLE = $(OBJDIR)/proj2$(EXE) - # PROJECT_MODULES = mod21 modcommon - # PROJECT_CMODULES = - # PROJEC_LIBS = unix str - # include Makefile.ocaml.build - - -CAMLLEX = ocamllex -CAMLYACC= ocamlyacc -v -CAMLDEP = ocamldep - -COMPILEFLAGS += -I $(OBJDIR) - -# sm: two styles for echoing compilation progress: -# style 1, by George: -# - print English descriptions of what's happening -# - set ECHO to "" to see *everything* -# style 2, by Scott: -# - do not print English descriptions -# - print every shell command that is executed which has a side effect, -# so that they could be pasted into a shell to reproduce manually -# - omit some of the details of dependency generation -# -# to be able to choose which style, several variables are used: -# @$(NARRATIVE) - put this before English descriptions for style 1 -# @$(COMMAND) - put this before shell commands which are to be -# printed for style 2; the command is *not* executed -# $(AT) - put this before shell commands which are to be executed, -# and also printed in style 2 -# $(ECHO) - use in place of '@' for things not printed in either style -ifdef ECHOSTYLE_SCOTT - # 'true' silently consumes its arguments, whereas 'echo' prints them - NARRATIVE := true - COMMAND := echo - AT := - ECHO := @ -else - NARRATIVE := echo - COMMAND := true - # change these next two definitions to to echo everything, - # or leave as @ to suppress echoing - AT := @ - ECHO := @ -endif - -ifdef PREPROC - COMPILEFLAGS += -pp "$(PREPROC)$" - DEPFLAGS += -pp "$(PREPROC)" -endif - -COMPILEMSG= -LINKMSG= - -ifdef WIN32 -OBJ = obj -else -OBJ = o -endif -EXE = $(EXEEXT).exe - - -export EXE - -ifdef NATIVECAML - ifdef PROFILE - COMPILEFLAGS += -p - LINKFLAGS += -p - COMPILEMSG += (profile) - LINKMSG += (profile) - endif - ifdef ASSEMBLY - COMPILEFLAGS += -S - endif - ifdef STATIC - COMPILEFLAGS += -ccopt -static - LINKFLAGS += -ccopt -static - endif - #foo := $(shell echo "I am in NATIVECAML mode" >&2; echo whatever) - ifdef WIN32 - COMPILEFLAGS += -ccopt /Ox - else - COMPILEFLAGS += -ccopt -O3 - endif - CAMLC = $(CAMLDIR)ocamlopt $(COMPILEFLAGS) - CAMLLINK = $(CAMLDIR)ocamlopt $(LINKFLAGS) - CMO = cmx - CMC = opt.$(OBJ) # compiled (and optimized) C - CMXA = cmxa - EXEEXT = .asm - MOVEAFTERCAMLC = cmi cmx $(OBJ) - COMPILETOWHAT = native code - # sm: by adding -native in native mode, we prevent spurious - # dependencies on .cmo files which were causing lots of - # extra recompilation - CAMLDEP = $(CAMLDIR)ocamldep -native -else - CMO = cmo - CMXA = cma - CMC = $(OBJ) - EXEEXT = .byte - MOVEAFTERCAMLC = cmi cmo - COMPILETOWHAT = bytecode - ifdef WIN32 - COMPILEFLAGS += -ccopt /Zi -ccopt /Od - LINKFLAGS += -ccopt /Zi -ccopt /Od - else - COMPILEFLAGS += -g - LINKFLAGS += -g - endif - CAMLC = $(CAMLDIR)ocamlc -g $(COMPILEFLAGS) - CAMLLINK = $(CAMLDIR)ocamlc -custom $(LINKFLAGS) -endif - - -ifdef UNSAFE - CAMLC := $(CAMLC) -unsafe -noassert -endif - - - - - # Allow searching for .ml and .mli -vpath %.mll $(SOURCEDIRS) -vpath %.mly $(SOURCEDIRS) -vpath %.ml $(SOURCEDIRS) $(OBJDIR) -vpath %.mli $(SOURCEDIRS) $(OBJDIR) -vpath %.c $(SOURCEDIRS) - - -# Secondaries are intermediates that we don't want make to delete -# By giving the right names to secondary files we tell make where to make -# them if they are not already made. VERY USEFUL!! -.SECONDARY : $(MLLS:%.mll=$(OBJDIR)/%.ml) $(MLYS:%.mly=$(OBJDIR)/%.ml) \ - $(MLYS:%.mly=$(OBJDIR)/%.mli) - - # Run the lexer generator - # Move the result to the OBJDIR directory - # If there is a .mli file in the same directory with .mll then - # copy it to OBJDIR (where the .ml) file will live. -$(OBJDIR)/%.ml: %.mll - $(CAMLLEX) $< - $(AT)mv -f $(basename $<).ml $(OBJDIR)/ - $(ECHO)if test -f $(basename $<).mli ;then \ - $(COMMAND) cp -f $(basename $<).mli $(OBJDIR)/; \ - cp -f $(basename $<).mli $(OBJDIR)/ \ - ;fi - - # Run the parser generator - # Move the result to the $(OBJDIR) directory. -$(OBJDIR)/%.ml $(OBJDIR)/%.mli: %.mly - $(CAMLYACC) $(CAMLYACCFLAGS) $< - $(AT)mv -f $(basename $<).ml $(basename $<).mli $(OBJDIR)/ - - # Compile an MLI file. After compilation move the result to OBJDIR -$(OBJDIR)/%.cmi: %.mli - @$(NARRATIVE) Compiling interface $< - $(AT)$(CAMLC) $(COMPILEFLAGS) -c $< - $(ECHO)if test $(OBJDIR) != $() { s%[^/\\ :]*/% %g; s%[^/\\ :]+\\% %g; s%([-a-zA-Z0-9+-.:/\/_]+)%\$$(OBJDIR)/$$1%g; print $$_;}' -# FIXDEPEND:=cat - -DEPINCLUDES= -I $(OBJDIR) $(SOURCEDIRS:%=-I %) -$(DEPENDDIR)/%.d: %.ml - @$(NARRATIVE) Generating dependency information for $< - @$(COMMAND) $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< - $(ECHO)$(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< | $(FIXDEPEND) > $@ - -$(DEPENDDIR)/%.di: %.mli - @$(NARRATIVE) Generating dependency information for $< - @$(COMMAND) $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< - $(ECHO)$(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< | $(FIXDEPEND) > $@ - -# sm: it turns out there's a variable which lists all the goals -# specified on the command line; I'll use this to set CLEANING -# (which is not set anywhere else, currently) -ifeq ($(MAKECMDGOALS),clean) - #$(warning "Skipping dependency rules because we're cleaning") - CLEANING := 1 -endif - -ifndef CLEANING --include $(MODULES:%=$(DEPENDDIR)/%.d) --include $(MODULES:%=$(DEPENDDIR)/%.di) -endif - -listmodules: - @echo $(MODULES) diff --git a/cil/ocamlutil/Makefile.ocaml.build b/cil/ocamlutil/Makefile.ocaml.build deleted file mode 100644 index 5271e46..0000000 --- a/cil/ocamlutil/Makefile.ocaml.build +++ /dev/null @@ -1,50 +0,0 @@ -# -*- Mode: makefile -*- -# Copyright (c) 2001-2002, -# George C. Necula -# Scott McPeak -# Wes Weimer -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# 3. The names of the contributors may not be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - # Auxiliary Makefile for building Ocaml project. See the documentation in - # the associated Makefile.ocaml for how to use this file. - # Written by necula@cs.berkeley.edu - # -$(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \ - $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC)) - @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)" - $(AT)$(CAMLLINK) -verbose -o $@ \ - $(PROJECT_LIBS:%=%.$(CMXA)) \ - $(PROJECT_LIBS:%=-cclib -l%) \ - $^ - - - - - diff --git a/cil/ocamlutil/alpha.ml b/cil/ocamlutil/alpha.ml deleted file mode 100755 index 6a1ea01..0000000 --- a/cil/ocamlutil/alpha.ml +++ /dev/null @@ -1,156 +0,0 @@ -module H = Hashtbl -module E = Errormsg -open Pretty - -let debugAlpha (prefix: string) = false -(*** Alpha conversion ***) -let alphaSeparator = "___" -let alphaSeparatorLen = String.length alphaSeparator - -(** For each prefix we remember the next integer suffix to use and the list - * of suffixes, each with some data assciated with the newAlphaName that - * created the suffix. *) -type 'a alphaTableData = int * (string * 'a) list - -type 'a undoAlphaElement = - AlphaChangedSuffix of 'a alphaTableData ref * 'a alphaTableData (* The - * reference that was changed and - * the old suffix *) - | AlphaAddedSuffix of string (* We added this new entry to the - * table *) - -(* Create a new name based on a given name. The new name is formed from a - * prefix (obtained from the given name by stripping a suffix consisting of - * the alphaSeparator followed by only digits), followed by alphaSeparator - * and then by a positive integer suffix. The first argument is a table - * mapping name prefixes to the largest suffix used so far for that - * prefix. The largest suffix is one when only the version without suffix has - * been used. *) -let rec newAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t) - ~(undolist: 'a undoAlphaElement list ref option) - ~(lookupname: string) - ~(data: 'a) : string * 'a = - alphaWorker ~alphaTable:alphaTable ~undolist:undolist - ~lookupname:lookupname ~data:data true - - -(** Just register the name so that we will not use in the future *) -and registerAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t) - ~(undolist: 'a undoAlphaElement list ref option) - ~(lookupname: string) - ~(data: 'a) : unit = - ignore (alphaWorker ~alphaTable:alphaTable ~undolist:undolist - ~lookupname:lookupname ~data:data false) - - -and alphaWorker ~(alphaTable: (string, 'a alphaTableData ref) H.t) - ~(undolist: 'a undoAlphaElement list ref option) - ~(lookupname: string) ~(data:'a) - (make_new: bool) : string * 'a = - let prefix, suffix, (numsuffix: int) = splitNameForAlpha ~lookupname in - if debugAlpha prefix then - ignore (E.log "Alpha worker: prefix=%s suffix=%s (%d) create=%b. " - prefix suffix numsuffix make_new); - let newname, (olddata: 'a) = - try - let rc = H.find alphaTable prefix in - let max, suffixes = !rc in - (* We have seen this prefix *) - if debugAlpha prefix then - ignore (E.log " Old max %d. Old suffixes: @[%a@]" max - (docList - (fun (s, l) -> dprintf "%s" (* d_loc l *) s)) suffixes); - (* Save the undo info *) - (match undolist with - Some l -> l := AlphaChangedSuffix (rc, !rc) :: !l - | _ -> ()); - - let newmax, newsuffix, (olddata: 'a), newsuffixes = - if numsuffix > max then begin - (* Clearly we have not seen it *) - numsuffix, suffix, data, - (suffix, data) :: suffixes - end else begin - match List.filter (fun (n, _) -> n = suffix) suffixes with - [] -> (* Not found *) - max, suffix, data, (suffix, data) :: suffixes - | [(_, l) ] -> - (* We have seen this exact suffix before *) - if make_new then - let newsuffix = alphaSeparator ^ (string_of_int (max + 1)) in - max + 1, newsuffix, l, (newsuffix, data) :: suffixes - else - max, suffix, data, suffixes - | _ -> E.s (E.bug "Cil.alphaWorker") - end - in - rc := (newmax, newsuffixes); - prefix ^ newsuffix, olddata - with Not_found -> begin (* First variable with this prefix *) - (match undolist with - Some l -> l := AlphaAddedSuffix prefix :: !l - | _ -> ()); - H.add alphaTable prefix (ref (numsuffix, [ (suffix, data) ])); - if debugAlpha prefix then ignore (E.log " First seen. "); - lookupname, data (* Return the original name *) - end - in - if debugAlpha prefix then - ignore (E.log " Res=: %s \n" newname (* d_loc oldloc *)); - newname, olddata - -(* Strip the suffix. Return the prefix, the suffix (including the separator - * and the numeric value, possibly empty), and the - * numeric value of the suffix (possibly -1 if missing) *) -and splitNameForAlpha ~(lookupname: string) : (string * string * int) = - let len = String.length lookupname in - (* Search backward for the numeric suffix. Return the first digit of the - * suffix. Returns len if no numeric suffix *) - let rec skipSuffix (i: int) = - if i = -1 then -1 else - let c = Char.code (String.get lookupname i) - Char.code '0' in - if c >= 0 && c <= 9 then - skipSuffix (i - 1) - else (i + 1) - in - let startSuffix = skipSuffix (len - 1) in - - if startSuffix >= len (* No digits at all at the end *) || - startSuffix <= alphaSeparatorLen (* Not enough room for a prefix and - * the separator before suffix *) || - (* Suffix starts with a 0 and has more characters after that *) - (startSuffix < len - 1 && String.get lookupname startSuffix = '0') || - alphaSeparator <> String.sub lookupname - (startSuffix - alphaSeparatorLen) - alphaSeparatorLen - then - (lookupname, "", -1) (* No valid suffix in the name *) - else - (String.sub lookupname 0 (startSuffix - alphaSeparatorLen), - String.sub lookupname (startSuffix - alphaSeparatorLen) - (len - startSuffix + alphaSeparatorLen), - int_of_string (String.sub lookupname startSuffix (len - startSuffix))) - - -let getAlphaPrefix ~(lookupname:string) : string = - let p, _, _ = splitNameForAlpha ~lookupname:lookupname in - p - -(* Undoes the changes as specified by the undolist *) -let undoAlphaChanges ~(alphaTable: (string, 'a alphaTableData ref) H.t) - ~(undolist: 'a undoAlphaElement list) = - List.iter - (function - AlphaChangedSuffix (where, old) -> - where := old - | AlphaAddedSuffix name -> - if debugAlpha name then - ignore (E.log "Removing %s from alpha table\n" name); - H.remove alphaTable name) - undolist - -let docAlphaTable () (alphaTable: (string, 'a alphaTableData ref) H.t) = - let acc : (string * (int * (string * 'a) list)) list ref = ref [] in - H.iter (fun k d -> acc := (k, !d) :: !acc) alphaTable; - docList ~sep:line (fun (k, (d, _)) -> dprintf " %s -> %d" k d) () !acc - diff --git a/cil/ocamlutil/alpha.mli b/cil/ocamlutil/alpha.mli deleted file mode 100755 index e1e430d..0000000 --- a/cil/ocamlutil/alpha.mli +++ /dev/null @@ -1,50 +0,0 @@ -(** {b ALPHA conversion} *) - -(** This is the type of the elements that are recorded by the alpha - * conversion functions in order to be able to undo changes to the tables - * they modify. Useful for implementing - * scoping *) -type 'a undoAlphaElement - -(** This is the type of the elements of the alpha renaming table. These - * elements can carry some data associated with each occurrence of the name. *) -type 'a alphaTableData - - -(** Create a new name based on a given name. The new name is formed from a - * prefix (obtained from the given name by stripping a suffix consisting of _ - * followed by only digits), followed by a special separator and then by a - * positive integer suffix. The first argument is a table mapping name - * prefixes to some data that specifies what suffixes have been used and how - * to create the new one. This function updates the table with the new - * largest suffix generated. The "undolist" argument, when present, will be - * used by the function to record information that can be used by - * {!Alpha.undoAlphaChanges} to undo those changes. Note that the undo - * information will be in reverse order in which the action occurred. Returns - * the new name and, if different from the lookupname, the location of the - * previous occurrence. This function knows about the location implicitly - * from the {!Cil.currentLoc}. *) -val newAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> - undolist: 'a undoAlphaElement list ref option -> - lookupname:string -> data:'a -> string * 'a - - -(** Register a name with an alpha conversion table to ensure that when later - * we call newAlphaName we do not end up generating this one *) -val registerAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> - undolist: 'a undoAlphaElement list ref option -> - lookupname:string -> data:'a -> unit - -(** Split the name in preparation for newAlphaName. The prefix returned is - used to index into the hashtable. The next result value is a separator - (either empty or the separator chosen to separate the original name from - the index) *) -val docAlphaTable: unit -> - (string, 'a alphaTableData ref) Hashtbl.t -> Pretty.doc - - -val getAlphaPrefix: lookupname:string -> string - -(** Undo the changes to a table *) -val undoAlphaChanges: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> - undolist:'a undoAlphaElement list -> unit diff --git a/cil/ocamlutil/clist.ml b/cil/ocamlutil/clist.ml deleted file mode 100644 index 80f0fd6..0000000 --- a/cil/ocamlutil/clist.ml +++ /dev/null @@ -1,183 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -open Pretty - - -(* We often need to concatenate sequences and using lists for this purpose is - * expensive. So we define a kind of "concatenable lists" that are easier to - * concatenate *) -type 'a clist = - | CList of 'a list (* This is the only representation for empty - * *) - | CConsL of 'a * 'a clist - | CConsR of 'a clist * 'a - | CSeq of 'a clist * 'a clist (* We concatenate only two of them at this - * time. Neither is CEmpty. To be sure - * always use append to make these *) - -let rec listifyOnto (tail: 'a list) = function - CList l -> l @ tail - | CConsL (x, l) -> x :: listifyOnto tail l - | CConsR (l, x) -> listifyOnto (x :: tail) l - | CSeq (l1, l2) -> listifyOnto (listifyOnto tail l2) l1 - -let toList l = listifyOnto [] l -let fromList l = CList l - - -let single x = CList [x] -let empty = CList [] - -let checkBeforeAppend (l1: 'a clist) (l2: 'a clist) : bool = - l1 != l2 || l1 = (CList []) - -let append l1 l2 = - if l1 = CList [] then l2 else - if l2 = CList [] then l1 else - begin - if l1 == l2 then - raise (Failure "You should not use Clist.append to double a list"); - CSeq (l1, l2) - end - -let rec length (acc: int) = function - CList l -> acc + (List.length l) - | CConsL (x, l) -> length (acc + 1) l - | CConsR (l, _) -> length (acc + 1) l - | CSeq (l1, l2) -> length (length acc l1) l2 -let length l = length 0 l (* The external version *) - -let map (f: 'a -> 'b) (l: 'a clist) : 'b clist = - let rec loop = function - CList l -> CList (List.map f l) - | CConsL (x, l) -> let x' = f x in CConsL (x', loop l) - | CConsR (l, x) -> let l' = loop l in CConsR (l', f x) - | CSeq (l1, l2) -> let l1' = loop l1 in CSeq (l1', loop l2) - in - loop l - - -let fold_left (f: 'acc -> 'a -> 'acc) (start: 'acc) (l: 'a clist) = - let rec loop (start: 'acc) = function - CList l -> List.fold_left f start l - | CConsL (x, l) -> loop (f start x) l - | CConsR (l, x) -> let res = loop start l in f res x - | CSeq (l1, l2) -> - let res1 = loop start l1 in - loop res1 l2 - in - loop start l - -let iter (f: 'a -> unit) (l: 'a clist) : unit = - let rec loop = function - CList l -> List.iter f l - | CConsL (x, l) -> f x; loop l - | CConsR (l, x) -> loop l; f x - | CSeq (l1, l2) -> loop l1; loop l2 - in - loop l - - -let rec rev (revelem: 'a -> 'a) = function - CList l -> - let rec revonto (tail: 'a list) = function - [] -> tail - | x :: rest -> revonto (revelem x :: tail) rest - in - CList (revonto [] l) - - | CConsL (x, l) -> CConsR (rev revelem l, x) - | CConsR (l, x) -> CConsL (x, rev revelem l) - | CSeq (l1, l2) -> CSeq (rev revelem l2, rev revelem l1) - - -let docCList (sep: doc) (doone: 'a -> doc) () (dl: 'a clist) = - fold_left - (fun (acc: doc) (elem: 'a) -> - let elemd = doone elem in - if acc == nil then elemd else acc ++ sep ++ elemd) - nil - dl - - -(* let debugCheck (lst: 'a clist) : unit =*) -(* (* use a hashtable to store values encountered *)*) -(* let tbl : 'a bool H.t = (H.create 13) in*) - -(* letrec recurse (node: 'a clist) =*) -(* (* have we seen*)*) - -(* match node with*) -(* | CList*) - - -(* --------------- testing ----------------- *) -type boxedInt = - | BI of int - | SomethingElse - -let d_boxedInt () b = - match b with - | BI(i) -> (dprintf "%d" i) - | SomethingElse -> (text "somethingElse") - - -(* sm: some simple tests of CLists -let testCList () : unit = -begin - (trace "sm" (dprintf "in testCList\n")); - - let clist1 = (fromList [BI(1); BI(2); BI(3)]) in - (trace "sm" (dprintf "length of clist1 is %d\n" - (length clist1) )); - - let flattened = (toList clist1) in - (trace "sm" (dprintf "flattened: %a\n" - (docList ~sep:(chr ',' ++ break) (d_boxedInt ())) - flattened)); - - -end -1) in - (trace "sm" (dprintf "flattened: %a\n" - (docList ~sep:(chr ',' ++ break) (d_boxedInt ())) - flattened)); - - -end -*) diff --git a/cil/ocamlutil/clist.mli b/cil/ocamlutil/clist.mli deleted file mode 100644 index c0378a6..0000000 --- a/cil/ocamlutil/clist.mli +++ /dev/null @@ -1,97 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** Utilities for managing "concatenable lists" (clists). We often need to - concatenate sequences, and using lists for this purpose is expensive. This - module provides routines to manage such lists more efficiently. In this - model, we never do cons or append explicitly. Instead we maintain - the elements of the list in a special data structure. Routines are provided - to convert to/from ordinary lists, and carry out common list operations.*) - -(** The clist datatype. A clist can be an ordinary list, or a clist preceded - or followed by an element, or two clists implicitly appended together*) -type 'a clist = - | CList of 'a list (** The only representation for the empty - list. Try to use sparingly. *) - | CConsL of 'a * 'a clist (** Do not use this a lot because scanning - * it is not tail recursive *) - | CConsR of 'a clist * 'a - | CSeq of 'a clist * 'a clist (** We concatenate only two of them at this - time. Neither is the empty clist. To be - sure always use append to make these *) - - -(** Convert a clist to an ordinary list *) -val toList: 'a clist -> 'a list - -(** Convert an ordinary list to a clist *) -val fromList: 'a list -> 'a clist - -(** Create a clist containing one element *) -val single: 'a -> 'a clist - -(** The empty clist *) -val empty: 'a clist - - -(** Append two clists *) -val append: 'a clist -> 'a clist -> 'a clist - -(** A useful check to assert before an append. It checks that the two lists - * are not identically the same (Except if they are both empty) *) -val checkBeforeAppend: 'a clist -> 'a clist -> bool - -(** Find the length of a clist *) -val length: 'a clist -> int - -(** Map a function over a clist. Returns another clist *) -val map: ('a -> 'b) -> 'a clist -> 'b clist - - -(** A version of fold_left that works on clists *) -val fold_left: ('acc -> 'a -> 'acc) -> 'acc -> 'a clist -> 'acc - -(** A version of iter that works on clists *) -val iter: ('a -> unit) -> 'a clist -> unit - -(** Reverse a clist. The first function reverses an element. *) -val rev: ('a -> 'a) -> 'a clist -> 'a clist - -(** A document for printing a clist (similar to [docList]) *) -val docCList: - Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a clist -> Pretty.doc - diff --git a/cil/ocamlutil/errormsg.ml b/cil/ocamlutil/errormsg.ml deleted file mode 100644 index 07e935d..0000000 --- a/cil/ocamlutil/errormsg.ml +++ /dev/null @@ -1,337 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -open Pretty - - - -let debugFlag = ref false (* If set then print debugging info *) -let verboseFlag = ref false - -(**** Error reporting ****) -exception Error -let s (d : 'a) = raise Error - -let hadErrors = ref false - -let errorContext = ref [] -let pushContext f = errorContext := f :: (!errorContext) -let popContext () = - match !errorContext with - _ :: t -> errorContext := t - | [] -> s (eprintf "Bug: cannot pop error context") - - -let withContext ctx f x = - pushContext ctx; - try - let res = f x in - popContext (); - res - with e -> begin - popContext (); - raise e - end - - (* Make sure that showContext calls - * each f with its appropriate - * errorContext as it was when it was - * pushed *) -let showContext () = - let rec loop = function - [] -> () - | f :: rest -> (errorContext := rest; (* Just in case f raises an error *) - ignore (eprintf " Context : %t@!" f); - loop rest) - in - let old = !errorContext in - try - loop old; - errorContext := old - with e -> begin - errorContext := old; - raise e - end - -let contextMessage (name: string) (d: doc) = - ignore (eprintf "@!%s: %a@!" name insert d); - showContext () - -let warnFlag = ref false - -let logChannel : out_channel ref = ref stderr - - -let bug (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = - hadErrors := true; contextMessage "Bug" d; - flush !logChannel - in - Pretty.gprintf f fmt - -let error (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = hadErrors := true; contextMessage "Error" d; - flush !logChannel - in - Pretty.gprintf f fmt - -let unimp (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = hadErrors := true; contextMessage "Unimplemented" d; - flush !logChannel - in - Pretty.gprintf f fmt - -let warn (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = contextMessage "Warning" d; flush !logChannel in - Pretty.gprintf f fmt - -let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = - if !warnFlag then contextMessage "Warning" d; - flush !logChannel in - Pretty.gprintf f fmt - - -let log (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = fprint !logChannel 80 d; flush !logChannel in - Pretty.gprintf f fmt - -let logg (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = fprint !logChannel 10000000 d; flush !logChannel in - Pretty.gprintf f fmt - -let null (fmt : ('a,unit,doc,unit) format4) : 'a = - let f d = () in - Pretty.gprintf f fmt - - -let theLexbuf = ref (Lexing.from_string "") - -let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr 80 x; - raise (Failure "")) format - - - -(***** Handling parsing errors ********) -type parseinfo = - { mutable linenum: int ; (* Current line *) - mutable linestart: int ; (* The position in the buffer where the - * current line starts *) - mutable fileName : string ; (* Current file *) - mutable hfile : string ; (* High-level file *) - mutable hline : int; (* High-level line *) - lexbuf : Lexing.lexbuf; - inchan : in_channel option; (* None, if from a string *) - mutable num_errors : int; (* Errors so far *) - } - -let dummyinfo = - { linenum = 1; - linestart = 0; - fileName = "" ; - lexbuf = Lexing.from_string ""; - inchan = None; - hfile = ""; - hline = 0; - num_errors = 0; - } - -let current = ref dummyinfo - -let setHLine (l: int) : unit = - !current.hline <- l -let setHFile (f: string) : unit = - !current.hfile <- f - -let rem_quotes str = String.sub str 1 ((String.length str) - 2) - -(* Change \ into / in file names. To avoid complications with escapes *) -let cleanFileName str = - let str1 = - if str <> "" && String.get str 0 = '"' (* '"' ( *) - then rem_quotes str else str in - let l = String.length str1 in - let rec loop (copyto: int) (i: int) = - if i >= l then - String.sub str1 0 copyto - else - let c = String.get str1 i in - if c <> '\\' then begin - String.set str1 copyto c; loop (copyto + 1) (i + 1) - end else begin - String.set str1 copyto '/'; - if i < l - 2 && String.get str1 (i + 1) = '\\' then - loop (copyto + 1) (i + 2) - else - loop (copyto + 1) (i + 1) - end - in - loop 0 0 - -let readingFromStdin = ref false - -let startParsing ?(useBasename=true) (fname: string) = - (* We only support one open file at a time *) - if !current != dummyinfo then begin - s (error "Errormsg.startParsing supports only one open file: You want to open %s and %s is still open\n" fname !current.fileName); - end; - let inchan = - try if fname = "-" then begin - readingFromStdin := true; - stdin - end else begin - readingFromStdin := false; - open_in fname - end - with e -> s (error "Cannot find input file %s (exception %s" - fname (Printexc.to_string e)) in - let lexbuf = Lexing.from_channel inchan in - let i = - { linenum = 1; linestart = 0; - fileName = - cleanFileName (if useBasename then Filename.basename fname else fname); - lexbuf = lexbuf; inchan = Some inchan; - hfile = ""; hline = 0; - num_errors = 0 } in - - current := i; - lexbuf - -let startParsingFromString ?(file="") ?(line=1) (str: string) = - let lexbuf = Lexing.from_string str in - let i = - { linenum = line; linestart = line - 1; - fileName = file; - hfile = ""; hline = 0; - lexbuf = lexbuf; - inchan = None; - num_errors = 0 } - in - current := i; - lexbuf - -let finishParsing () = - let i = !current in - (match i.inchan with Some c -> close_in c | _ -> ()); - current := dummyinfo - - -(* Call this function to announce a new line *) -let newline () = - let i = !current in - i.linenum <- 1 + i.linenum; - i.linestart <- Lexing.lexeme_start i.lexbuf - -let newHline () = - let i = !current in - i.hline <- 1 + i.hline - -let setCurrentLine (i: int) = - !current.linenum <- i - -let setCurrentFile (n: string) = - !current.fileName <- cleanFileName n - - -let max_errors = 20 (* Stop after 20 errors *) - -let parse_error (msg: string) : 'a = - (* Sometimes the Ocaml parser raises errors in symbol_start and symbol_end *) - let token_start, token_end = - try Parsing.symbol_start (), Parsing.symbol_end () - with e -> begin - ignore (warn "Parsing raised %s\n" (Printexc.to_string e)); - 0, 0 - end - in - let i = !current in - let adjStart = - if token_start < i.linestart then 0 else token_start - i.linestart in - let adjEnd = - if token_end < i.linestart then 0 else token_end - i.linestart in - output_string - stderr - (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":" - ^ (string_of_int adjStart) ^ "-" - ^ (string_of_int adjEnd) - ^ "]" - ^ " : " ^ msg); - output_string stderr "\n"; - flush stderr ; - i.num_errors <- i.num_errors + 1; - if i.num_errors > max_errors then begin - output_string stderr "Too many errors. Aborting.\n" ; - exit 1 - end; - hadErrors := true; - raise Parsing.Parse_error - - - - -(* More parsing support functions: line, file, char count *) -let getPosition () : int * string * int = - let i = !current in - i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf - - -let getHPosition () = - !current.hline, !current.hfile - -(** Type for source-file locations *) -type location = - { file: string; (** The file name *) - line: int; (** The line number *) - hfile: string; (** The high-level file name, or "" if not present *) - hline: int; (** The high-level line number, or 0 if not present *) - } - -let d_loc () l = - text (l.file ^ ":" ^ string_of_int l.line) - -let d_hloc () (l: location) = - dprintf "%s:%d%a" l.file l.line - insert (if l.hline > 0 then dprintf " (%s:%d)" l.hfile l.hline else nil) - -let locUnknown = { file = ""; hfile = ""; line = -1; hline = -1 } - -let getLocation () = - let hl, hf = getHPosition () in - let l, f, c = getPosition () in - { hfile = hf; hline = hl; - file = f; line = l } - diff --git a/cil/ocamlutil/errormsg.mli b/cil/ocamlutil/errormsg.mli deleted file mode 100644 index 8d9c697..0000000 --- a/cil/ocamlutil/errormsg.mli +++ /dev/null @@ -1,164 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(** Utility functions for error-reporting *) - -(** A channel for printing log messages *) -val logChannel : out_channel ref - -(** If set then print debugging info *) -val debugFlag : bool ref - -val verboseFlag : bool ref - - -(** Set to true if you want to see all warnings. *) -val warnFlag: bool ref - -(** Error reporting functions raise this exception *) -exception Error - - - (* Error reporting. All of these functions take same arguments as a - * Pretty.eprintf. They set the hadErrors flag, but do not raise an - * exception. Their return type is unit. - *) - -(** Prints an error message of the form [Error: ...]. - Use in conjunction with s, for example: [E.s (E.error ... )]. *) -val error: ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** Similar to [error] except that its output has the form [Bug: ...] *) -val bug: ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** Similar to [error] except that its output has the form [Unimplemented: ...] *) -val unimp: ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** Stop the execution by raising an Error. *) -val s: 'a -> 'b - -(** This is set whenever one of the above error functions are called. It must - be cleared manually *) -val hadErrors: bool ref - -(** Like {!Errormsg.error} but does not raise the {!Errormsg.Error} - * exception. Return type is unit. *) -val warn: ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** Like {!Errormsg.warn} but optional. Printed only if the - * {!Errormsg.warnFlag} is set *) -val warnOpt: ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** Print something to [logChannel] *) -val log: ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** same as {!Errormsg.log} but do not wrap lines *) -val logg: ('a,unit,Pretty.doc,unit) format4 -> 'a - - (* All of the error and warning reporting functions can also print a - * context. To register a context printing function use "pushContext". To - * remove the last registered one use "popContext". If one of the error - * reporting functions is called it will invoke all currently registered - * context reporting functions in the reverse order they were registered. *) - -(** Do not actually print (i.e. print to /dev/null) *) -val null : ('a,unit,Pretty.doc,unit) format4 -> 'a - -(** Registers a context printing function *) -val pushContext : (unit -> Pretty.doc) -> unit - -(** Removes the last registered context printing function *) -val popContext : unit -> unit - -(** Show the context stack to stderr *) -val showContext : unit -> unit - -(** To ensure that the context is registered and removed properly, use the - function below *) -val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b - - - -val newline: unit -> unit (* Call this function to announce a new line *) -val newHline: unit -> unit - -val getPosition: unit -> int * string * int (* Line number, file name, - current byte count in file *) -val getHPosition: unit -> int * string (** high-level position *) - -val setHLine: int -> unit -val setHFile: string -> unit - -val setCurrentLine: int -> unit -val setCurrentFile: string -> unit - -(** Type for source-file locations *) -type location = - { file: string; (** The file name *) - line: int; (** The line number *) - hfile: string; (** The high-level file name, or "" if not present *) - hline: int; (** The high-level line number, or 0 if not present *) - } - -val d_loc: unit -> location -> Pretty.doc -val d_hloc: unit -> location -> Pretty.doc - -val getLocation: unit -> location - -val parse_error: string -> (* A message *) - 'a - -(** An unknown location for use when you need one but you don't have one *) -val locUnknown: location - - -(** Records whether the stdin is open for reading the goal **) -val readingFromStdin: bool ref - - -(* Call this function to start parsing. useBasename is by default "true", - * meaning that the error information maintains only the basename. If the - * file name is - then it reads from stdin. *) -val startParsing: ?useBasename:bool -> string -> - Lexing.lexbuf - -val startParsingFromString: ?file:string -> ?line:int -> string - -> Lexing.lexbuf - -val finishParsing: unit -> unit (* Call this function to finish parsing and - * close the input channel *) - - diff --git a/cil/ocamlutil/growArray.ml b/cil/ocamlutil/growArray.ml deleted file mode 100644 index ccadc76..0000000 --- a/cil/ocamlutil/growArray.ml +++ /dev/null @@ -1,191 +0,0 @@ -(** Growable Arrays *) - -type 'a fill = - Elem of 'a - | Susp of (int -> 'a) - -type 'a t = { - gaFill: 'a fill; - (** Stuff to use to fill in the array as it grows *) - - mutable gaMaxInitIndex: int; - (** Maximum index that was written to. -1 if no writes have - * been made. *) - - mutable gaData: 'a array; - } - -let growTheArray (ga: 'a t) (len: int) - (toidx: int) (why: string) : unit = - if toidx >= len then begin - (* Grow the array by 50% *) - let newlen = toidx + 1 + len / 2 in -(* - ignore (E.log "growing an array to idx=%d (%s)\n" toidx why); -*) - let data' = begin match ga.gaFill with - Elem x -> - let data'' = Array.create newlen x in - Array.blit ga.gaData 0 data'' 0 len; - data'' - | Susp f -> Array.init newlen - (fun i -> if i < len then ga.gaData.(i) else f i) - end - in - ga.gaData <- data' - end - -let max_init_index (ga: 'a t) : int = - ga.gaMaxInitIndex - -let num_alloc_index (ga: 'a t) : int = - Array.length ga.gaData - -let reset_max_init_index (ga: 'a t) : unit = - ga.gaMaxInitIndex <- -1 - -let getg (ga: 'a t) (r: int) : 'a = - let len = Array.length ga.gaData in - if r >= len then - growTheArray ga len r "getg"; - - ga.gaData.(r) - -let setg (ga: 'a t) (r: int) (what: 'a) : unit = - let len = Array.length ga.gaData in - if r >= len then - growTheArray ga len r "setg"; - if r > max_init_index ga then ga.gaMaxInitIndex <- r; - ga.gaData.(r) <- what - -let get (ga: 'a t) (r: int) : 'a = Array.get ga.gaData r - -let set (ga: 'a t) (r: int) (what: 'a) : unit = - if r > max_init_index ga then ga.gaMaxInitIndex <- r; - Array.set ga.gaData r what - -let make (initsz: int) (fill: 'a fill) : 'a t = - { gaFill = fill; - gaMaxInitIndex = -1; - gaData = begin match fill with - Elem x -> Array.create initsz x - | Susp f -> Array.init initsz f - end; } - -let clear (ga: 'a t) : unit = - (* This assumes the user hasn't used the raw "set" on any value past - max_init_index. Maybe we shouldn't trust max_init_index here?? *) - if ga.gaMaxInitIndex >= 0 then begin - begin match ga.gaFill with - Elem x -> Array.fill ga.gaData 0 (ga.gaMaxInitIndex+1) x - | Susp f -> - for i = 0 to ga.gaMaxInitIndex do - Array.set ga.gaData i (f i) - done - end; - ga.gaMaxInitIndex <- -1 - end - -let copy (ga: 'a t) : 'a t = - { ga with gaData = Array.copy ga.gaData } - -let deep_copy (ga: 'a t) (copy: 'a -> 'a): 'a t = - { ga with gaData = Array.map copy ga.gaData } - -(* An accumulating for loop. Used internally. *) -let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) = - let rec forloop i acc = - if i > hi then acc - else forloop (i+1) (f i acc) - in - forloop lo init - -(** Iterate over the initialized elements of the array *) -let iter (f: 'a -> unit) (ga: 'a t) = - for i = 0 to max_init_index ga do - f ga.gaData.(i) - done - -(** Iterate over the initialized elements of the array *) -let iteri (f: int -> 'a -> unit) (ga: 'a t) = - for i = 0 to max_init_index ga do - f i ga.gaData.(i) - done - -(** Iterate over the elements of 2 arrays *) -let iter2 (f: int -> 'a -> 'b -> unit) (ga1: 'a t) (ga2: 'b t) = - let len1 = max_init_index ga1 in - let len2 = max_init_index ga2 in - if len1 > -1 || len2 > -1 then begin - let max = if len1 > len2 then begin - ignore(getg ga2 len1); (*grow ga2 to match ga1*) - len1 - end else begin - ignore(getg ga1 len2); (*grow ga1 to match ga2*) - len2 - end in - for i = 0 to max do - f i ga1.gaData.(i) ga2.gaData.(i) - done - end - -(** Fold left over the initialized elements of the array *) -let fold_left (f: 'acc -> 'a -> 'acc) (acc: 'acc) (ga: 'a t) : 'acc = - let rec loop (acc: 'acc) (idx: int) : 'acc = - if idx > max_init_index ga then - acc - else - loop (f acc ga.gaData.(idx)) (idx + 1) - in - loop acc 0 - - -(** Fold left over the initialized elements of the array *) -let fold_lefti (f: 'acc -> int -> 'a -> 'acc) (acc: 'acc) (ga: 'a t) : 'acc = - let rec loop (acc: 'acc) (idx: int) : 'acc = - if idx > max_init_index ga then - acc - else - loop (f acc idx ga.gaData.(idx)) (idx + 1) - in - loop acc 0 - -(** Fold right over the initialized elements of the array *) -let fold_right (f: 'a -> 'acc -> 'acc) (ga: 'a t) (acc: 'acc) : 'acc = - let rec loop (acc: 'acc) (idx: int) : 'acc = - if idx < 0 then - acc - else - loop (f ga.gaData.(idx) acc) (idx - 1) - in - loop acc (max_init_index ga) - -(** Document generator *) -let d_growarray (sep: Pretty.doc) - (doit:int -> 'a -> Pretty.doc) - () - (elements: 'a t) = - Pretty.docArray ~sep:sep doit () elements.gaData - -let restoreGA ?deepCopy (ga: 'a t) : (unit -> unit) = - let old = - (match deepCopy with - None -> copy ga - | Some f -> deep_copy ga f) - in - (fun () -> - if ga.gaFill != old.gaFill then - Errormsg.s - (Errormsg.bug "restoreGA to an array with a different fill."); - ga.gaMaxInitIndex <- old.gaMaxInitIndex; - for i = 0 to max_init_index ga do - set ga i (getg old i) - done) - -let find (ga: 'a t) (fn: 'a -> bool) : int option = - let rec loop (i:int) : int option = - if i > ga.gaMaxInitIndex then None - else if fn (get ga i) then Some i - else loop (i + 1) - in - loop 0 diff --git a/cil/ocamlutil/growArray.mli b/cil/ocamlutil/growArray.mli deleted file mode 100644 index 4cb5f48..0000000 --- a/cil/ocamlutil/growArray.mli +++ /dev/null @@ -1,131 +0,0 @@ -(***********************************************************************) -(* Growable Arrays *) -(* *) -(* This a wrapper around the standard OCaml array, but will grow *) -(* automatically on get or set outside the current size of the *) -(* array. *) -(* *) -(* The interface is the same as the standard OCaml array where *) -(* applicable (and implemented). *) -(***********************************************************************) - -(* $Id: growArray.mli,v 1.8 2005-01-06 15:37:36 necula Exp $ *) - -(** Array operations. *) - -(** The type of growable arrays *) -type 'a t - -(** The default value to a new element of the growable array *) -type 'a fill = - Elem of 'a - (* A default value *) - | Susp of (int -> 'a) - (* A function given an index to generate a default value *) - -val make : int -> 'a fill -> 'a t -(** [GrowArray.make n x] returns a fresh growable array of size - at least [n] with default value specified by [x]. - - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. *) - -val num_alloc_index: 'a t -> int -(** [GrowArray.num_alloc_index a] returns the number of allocated entries in - * the array **) - -val max_init_index : 'a t -> int -(** [GrowArray.max_init_index a] returns the maximum index to - which has been written. - - Returns -1 if no writes have been made. *) - -val reset_max_init_index : 'a t -> unit -(** [GrowArray.reset_init a] resets the max_init_index. You should probably - use [GrowArray.clear a] instead if you also want to delete the contents. *) - -val getg : 'a t -> int -> 'a -(** [GrowArray.getg a n] returns the element number [n] of array [a]. - The first element has number 0. - The last element has number [GrowArray.length a - 1]. - - If [n] is outside the range 0 to [(GrowArray.max_init_index a)], - then the array grows to at least [n] and yields the default value. *) - -val setg : 'a t -> int -> 'a -> unit -(** [GrowArray.setg a n x] modifies array [a] in place, replacing - element number [n] with [x]. - - If [n] is outside the range 0 to [(GrowArray.max_init_index a)], - then the array grows to at least [n] and yields the default value. *) - -val get : 'a t -> int -> 'a -(** [GrowArray.get a n] returns the element number [n] of grow array [a]. - - Raise [Invalid_argument "Array.get"] if [n] is outside the range - of the underlying array. *) - -val set : 'a t -> int -> 'a -> unit -(** [GrowArray.set a n x] modifies grow array [a] in place, replacing - element number [n] with [x]. - - Raise [Invalid_argument "Array.set"] if [n] is outside the range - of the underlying array. *) - -val clear: 'a t -> unit -(** [GrowArray.clear a] clears the contents of the array and sets - max_init_index to -1. Suspension thunks will be rerun to regenerate the - initial values of the array. *) - -val copy : 'a t -> 'a t -(** [GrowArray.copy a] returns a copy of [a], that is, a fresh array - containing the same elements as [a]. *) - -val deep_copy : 'a t -> ('a -> 'a) -> 'a t -(** [GrowArray.copy a f] returns a deep copy of [a] using f to - copy elements of [a]. *) - -val iter : ('a -> unit) -> 'a t -> unit -(** [GrowArray.iter f a] applies function [f] in turn to all - the elements of [a]. It is equivalent to - [f a.(0); f a.(1); ...; f a.(GrowArray.length a - 1); ()]. *) - -val iteri : (int -> 'a -> unit) -> 'a t -> unit -(** Same as {!GrowArray.iter}, but the - function is applied to the index of the element as first argument, - and the element itself as second argument. *) - -val iter2 : (int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit -(** Same as {!GrowArray.iteri}, but the function is applied to two arrays. - [iter2 f a b] is equivalent to - [f 0 a.(0) b.(0); f 1 a.(1) b.(1); ...; f n a.(n) b.(n); ()] - where n is the larger of (max_init_index a) or (max_init_index b). - The shorter array will grow to match the longer.*) - -val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a -(** [GrowArray.fold_left f x a] computes - [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], - where [n] is the length of the array [a]. *) - -val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a -(** [GrowArray.fold_lefti f x a] computes - [f (... (f (f x 0 a.(0)) 1 a.(1)) ...) (n-1) a.(n-1)], - where [n] is the length of the array [a]. *) - -val fold_right : ('b -> 'a -> 'a) -> 'b t -> 'a -> 'a -(** [GrowArray.fold_right f a x] computes - [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], - where [n] is the length of the array [a]. *) - -val d_growarray : Pretty.doc -> (int -> 'a -> Pretty.doc) -> unit -> 'a t - -> Pretty.doc -(** [GrowArray.d_growarray sep f () a] creates a {!Pretty.doc} for growable - array a using separator sep and element printer f. *) - - -val restoreGA: ?deepCopy:('a -> 'a) -> 'a t -> unit -> unit -(** Given a growable array, produce a thunk that later restores it to its - current value *) - -val find: 'a t -> ('a -> bool) -> int option -(** Returns the index of the first element in the array that satisfies the - predicate, or None if there is no such element *) diff --git a/cil/ocamlutil/inthash.ml b/cil/ocamlutil/inthash.ml deleted file mode 100755 index b1ad0c0..0000000 --- a/cil/ocamlutil/inthash.ml +++ /dev/null @@ -1,188 +0,0 @@ -(** A hash table specialized on integer keys *) -type 'a t = - { mutable size: int; (* number of elements *) - mutable data: 'a bucketlist array } (* the buckets *) - -and 'a bucketlist = - Empty - | Cons of int * 'a * 'a bucketlist - -let hash key = key land 0x3fffffff - -let create initial_size = - let s = min (max 1 initial_size) Sys.max_array_length in - { size = 0; data = Array.make s Empty } - -let clear h = - for i = 0 to Array.length h.data - 1 do - h.data.(i) <- Empty - done; - h.size <- 0 - -let copy h = - { size = h.size; - data = Array.copy h.data } - -let copy_into src dest = - dest.size <- src.size; - dest.data <- Array.copy src.data - -let length h = h.size - -let resize tbl = - let odata = tbl.data in - let osize = Array.length odata in - let nsize = min (2 * osize + 1) Sys.max_array_length in - if nsize <> osize then begin - let ndata = Array.create nsize Empty in - let rec insert_bucket = function - Empty -> () - | Cons(key, data, rest) -> - insert_bucket rest; (* preserve original order of elements *) - let nidx = (hash key) mod nsize in - ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in - for i = 0 to osize - 1 do - insert_bucket odata.(i) - done; - tbl.data <- ndata; - end - -let add h key info = - let i = (hash key) mod (Array.length h.data) in - let bucket = Cons(key, info, h.data.(i)) in - h.data.(i) <- bucket; - h.size <- succ h.size; - if h.size > Array.length h.data lsl 1 then resize h - -let remove h key = - let rec remove_bucket = function - Empty -> - Empty - | Cons(k, i, next) -> - if k = key - then begin h.size <- pred h.size; next end - else Cons(k, i, remove_bucket next) in - let i = (hash key) mod (Array.length h.data) in - h.data.(i) <- remove_bucket h.data.(i) - -let remove_all h key = - let rec remove_bucket = function - Empty -> - Empty - | Cons(k, i, next) -> - if k = key - then begin h.size <- pred h.size; - remove_bucket next end - else Cons(k, i, remove_bucket next) in - let i = (hash key) mod (Array.length h.data) in - h.data.(i) <- remove_bucket h.data.(i) - -let rec find_rec key = function - Empty -> - raise Not_found - | Cons(k, d, rest) -> - if key = k then d else find_rec key rest - -let find h key = - match h.data.((hash key) mod (Array.length h.data)) with - Empty -> raise Not_found - | Cons(k1, d1, rest1) -> - if key = k1 then d1 else - match rest1 with - Empty -> raise Not_found - | Cons(k2, d2, rest2) -> - if key = k2 then d2 else - match rest2 with - Empty -> raise Not_found - | Cons(k3, d3, rest3) -> - if key = k3 then d3 else find_rec key rest3 - -let find_all h key = - let rec find_in_bucket = function - Empty -> - [] - | Cons(k, d, rest) -> - if k = key then d :: find_in_bucket rest else find_in_bucket rest in - find_in_bucket h.data.((hash key) mod (Array.length h.data)) - -let replace h key info = - let rec replace_bucket = function - Empty -> - raise Not_found - | Cons(k, i, next) -> - if k = key - then Cons(k, info, next) - else Cons(k, i, replace_bucket next) in - let i = (hash key) mod (Array.length h.data) in - let l = h.data.(i) in - try - h.data.(i) <- replace_bucket l - with Not_found -> - h.data.(i) <- Cons(key, info, l); - h.size <- succ h.size; - if h.size > Array.length h.data lsl 1 then resize h - -let mem h key = - let rec mem_in_bucket = function - | Empty -> - false - | Cons(k, d, rest) -> - k = key || mem_in_bucket rest in - mem_in_bucket h.data.((hash key) mod (Array.length h.data)) - -let iter (f: int -> 'a -> unit) (h: 'a t) : unit = - let rec do_bucket = function - Empty -> - () - | Cons(k, d, rest) -> - f k d; do_bucket rest in - let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket d.(i) - done - -let fold (f: int -> 'a -> 'b -> 'b) (h: 'a t) (init: 'b) = - let rec do_bucket b accu = - match b with - Empty -> - accu - | Cons(k, d, rest) -> - do_bucket rest (f k d accu) in - let d = h.data in - let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket d.(i) !accu - done; - !accu - - -let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a = - let i = (hash key) mod (Array.length h.data) in - let rec find_rec key = function - Empty -> addit () - | Cons(k, d, rest) -> - if key = k then d else find_rec key rest - and find_in_bucket key = function - Empty -> addit () - | Cons(k1, d1, rest1) -> - if key = k1 then d1 else - match rest1 with - Empty -> addit () - | Cons(k2, d2, rest2) -> - if key = k2 then d2 else - match rest2 with - Empty -> addit () - | Cons(k3, d3, rest3) -> - if key = k3 then d3 else find_rec key rest3 - and addit () = - let it = f key in - h.data.(i) <- Cons(key, it, h.data.(i)); - h.size <- succ h.size; - if h.size > Array.length h.data lsl 1 then resize h; - it - in - find_in_bucket key h.data.(i) - - -let tolist (h: 'a t) : (int * 'a) list = - fold (fun k d acc -> (k, d) :: acc) h [] diff --git a/cil/ocamlutil/inthash.mli b/cil/ocamlutil/inthash.mli deleted file mode 100755 index f62fcd2..0000000 --- a/cil/ocamlutil/inthash.mli +++ /dev/null @@ -1,27 +0,0 @@ -type 'a t - -(* These functions behave the same as Hashtbl, but the key type is - always int. (Specializing on int improves the performance) *) - -val create: int -> 'a t -val clear: 'a t -> unit -val length : 'a t -> int - -val copy: 'a t -> 'a t -val copy_into: 'a t -> 'a t -> unit - -val add: 'a t -> int -> 'a -> unit -val replace: 'a t -> int -> 'a -> unit -val remove: 'a t -> int -> unit -val remove_all: 'a t -> int -> unit - -val mem: 'a t -> int -> bool -val find: 'a t -> int -> 'a -val find_all: 'a t -> int -> 'a list - -val iter: (int -> 'a -> unit) -> 'a t -> unit -val fold: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - -val memoize: 'a t -> int -> (int -> 'a) -> 'a - -val tolist: 'a t -> (int * 'a) list diff --git a/cil/ocamlutil/intmap.ml b/cil/ocamlutil/intmap.ml deleted file mode 100755 index 00242bc..0000000 --- a/cil/ocamlutil/intmap.ml +++ /dev/null @@ -1,171 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: intmap.ml,v 1.2 2005-10-04 21:30:25 necula Exp $ *) - -(* specialized to integer keys by George Necula *) - -type 'a t = - Empty - | Node of 'a t * int * 'a * 'a t * int - -let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h - -let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - -let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - -let empty = Empty - -let is_empty = function Empty -> true | _ -> false - -let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) as t -> - if x = v then - Node(l, x, data, r, h) - else if x < v then - bal (add x data l) v d r - else - bal l v d (add x data r) - -let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - if x = v then d - else find x (if x < v then l else r) - -let rec mem x = function - Empty -> - false - | Node(l, v, d, r, _) -> - x = v || mem x (if x < v then l else r) - -let rec min_binding = function - Empty -> raise Not_found - | Node(Empty, x, d, r, _) -> (x, d) - | Node(l, x, d, r, _) -> min_binding l - -let rec remove_min_binding = function - Empty -> invalid_arg "Map.remove_min_elt" - | Node(Empty, x, d, r, _) -> r - | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r - -let merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (_, _) -> - let (x, d) = min_binding t2 in - bal t1 x d (remove_min_binding t2) - -let rec remove x = function - Empty -> - Empty - | Node(l, v, d, r, h) as t -> - if x = v then - merge l r - else if x < v then - bal (remove x l) v d r - else - bal l v d (remove x r) - -let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r - -let rec map f = function - Empty -> Empty - | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h) - -let rec mapi f = function - Empty -> Empty - | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h) - -let rec fold f m accu = - match m with - Empty -> accu - | Node(l, v, d, r, _) -> - fold f l (f v d (fold f r accu)) - -type 'a enumeration = End | More of int * 'a * 'a t * 'a enumeration - -let rec cons_enum m e = - match m with - Empty -> e - | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) - -let compare cmp m1 m2 = - let rec compare_aux e1 e2 = - match (e1, e2) with - (End, End) -> 0 - | (End, _) -> -1 - | (_, End) -> 1 - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> - if v1 <> v2 then if v1 < v2 then -1 else 1 else - let c = cmp d1 d2 in - if c <> 0 then c else - compare_aux (cons_enum r1 e1) (cons_enum r2 e2) -in compare_aux (cons_enum m1 End) (cons_enum m2 End) - -let equal cmp m1 m2 = - let rec equal_aux e1 e2 = - match (e1, e2) with - (End, End) -> true - | (End, _) -> false - | (_, End) -> false - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> - v1 = v2 && cmp d1 d2 && - equal_aux (cons_enum r1 e1) (cons_enum r2 e2) -in equal_aux (cons_enum m1 End) (cons_enum m2 End) - -(** Some definitions for ML2Coq *) -let _ = ignore "coq: -(* Some definitions for ML2Coq *) - -" diff --git a/cil/ocamlutil/intmap.mli b/cil/ocamlutil/intmap.mli deleted file mode 100755 index eef89b5..0000000 --- a/cil/ocamlutil/intmap.mli +++ /dev/null @@ -1,87 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: intmap.mli,v 1.1 2005-02-28 16:24:00 necula Exp $ *) - -(** Specialized to integer keys by George Necula *) - -(** Association tables over ordered types. - - This module implements applicative association tables, also known as - finite maps or dictionaries, given a total ordering function - over the keys. - All operations over maps are purely applicative (no side-effects). - The implementation uses balanced binary trees, and therefore searching - and insertion take time logarithmic in the size of the map. -*) - -type (+'a) t - (** The type of maps from type [key] to type ['a]. *) - -val empty: 'a t - (** The empty map. *) - -val is_empty: 'a t -> bool - (** Test whether a map is empty or not. *) - -val add: int -> 'a -> 'a t -> 'a t - (** [add x y m] returns a map containing the same bindings as - [m], plus a binding of [x] to [y]. If [x] was already bound - in [m], its previous binding disappears. *) - -val find: int -> 'a t -> 'a - (** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. *) - -val remove: int -> 'a t -> 'a t - (** [remove x m] returns a map containing the same bindings as - [m], except for [x] which is unbound in the returned map. *) - -val mem: int -> 'a t -> bool - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - -val iter: (int -> 'a -> unit) -> 'a t -> unit - (** [iter f m] applies [f] to all bindings in map [m]. - [f] receives the key as first argument, and the associated value - as second argument. The bindings are passed to [f] in increasing - order with respect to the ordering over the type of the keys. - Only current bindings are presented to [f]: - bindings hidden by more recent bindings are not passed to [f]. *) - -val map: ('a -> 'b) -> 'a t -> 'b t - (** [map f m] returns a map with same domain as [m], where the - associated value [a] of all bindings of [m] has been - replaced by the result of the application of [f] to [a]. - The bindings are passed to [f] in increasing order - with respect to the ordering over the type of the keys. *) - -val mapi: (int -> 'a -> 'b) -> 'a t -> 'b t - (** Same as {!Map.S.map}, but the function receives as arguments both the - key and the associated value for each binding of the map. *) - -val fold: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1 ... kN] are the keys of all bindings in [m] - (in increasing order), and [d1 ... dN] are the associated data. *) - -val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Total ordering between maps. The first argument is a total ordering - used to compare data associated with equal keys in the two maps. *) - -val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are - equal, that is, contain equal keys and associate them with - equal data. [cmp] is the equality predicate used to compare - the data associated with the keys. *) - diff --git a/cil/ocamlutil/perfcount.c.in b/cil/ocamlutil/perfcount.c.in deleted file mode 100755 index ae532f6..0000000 --- a/cil/ocamlutil/perfcount.c.in +++ /dev/null @@ -1,184 +0,0 @@ -// -*- Mode: c -*- -// -/* - * A module that allows the reading of performance counters on Pentium. - * - * This file contains both code that uses the performance counters to - * compute the number of cycles per second (to be used during ./configure) - * and also code to read the performance counters from Ocaml. - * - * Author: George Necula (necula@cs.berkeley.edu) - */ -#include -#include -#include - -#if defined(__GNUC__) - #define longlong long long - // RDTSC puts the result in EAX and EDX. We tell gcc to use those registers - // for "low" and "high" - #if defined(__i386__) - #define GETCOUNTER(low,high) \ - __asm__ volatile ("rdtsc" : "=a" (low), "=d" (high)); - #else - #define GETCOUNTER(low,high) \ - printf ("Reading of performance counters is supported only on Intel x86\n"); \ - exit(1); - #endif -#else - // Microsoft Visual Studio - #define longlong __int64 - #define inline __inline - #define GETCOUNTER(low,high) __asm { \ - __asm rdtsc \ - __asm mov low, eax \ - __asm mov high, edx }; -#endif - -/* Store here the first value read from the performance counter */ -unsigned static longlong first_value; - - -/* This is the function that actually reads the performance counter. */ -inline unsigned longlong read_ppc(void) { - unsigned long pclow, pchigh; - unsigned longlong lowhigh; - - GETCOUNTER(pclow, pchigh); - - // printf ("Read low=0x%08lx high=0x%08lx\n", low, high); - - // Put the 64-bit value together - lowhigh = ((unsigned longlong)pclow) | ((unsigned longlong)pchigh << 32); - - if(first_value == 0) { - first_value = lowhigh; - } - return lowhigh - first_value; -} - - -/* sm: I want a version that is as fast as possible, dropping - * bits that aren't very important to achieve it. * - * - * This version drops the low 20 bits and the high 14 bits so the - * result is 30 bits (always a positive Ocaml int); this yields - * megacycles, which for GHz machines will be something like - * milliseconds. */ -static unsigned long sample_ppc_20(void) -{ - unsigned long pclow, pchigh; - - GETCOUNTER(pclow, pchigh); - - return ((pclow >> 20) | (pchigh << 12)) & 0x3FFFFFFF; -} - -/* This version drops the low 10 bits, yielding something like - * microseconds. */ -inline static unsigned long sample_ppc_10() -{ - unsigned long pclow, pchigh; - - GETCOUNTER(pclow,pchigh); - - return ((pclow >> 10) | (pchigh << 22)) & 0x3FFFFFFF; -} - - - -#ifndef CONFIGURATION_ONLY -/*** This is the OCAML stub for the read_ppc ***/ -#include -#include -#include - -#define CYCLES_PER_USEC @CYCLES_PER_USEC@ -value read_pentium_perfcount() -{ - double counter = (double)read_ppc() / (1000000.0 * CYCLES_PER_USEC); - return copy_double(counter); -} - -/* The Ocaml system can use this function to figure out if there are - * performance counters available */ -value has_performance_counters() { - // HAS_PERFCOUNT is set by the configuration code at the end of - // this file, during ./configure -#if @HAS_PERFCOUNT@ != 0 - return Val_true; -#else - return Val_false; -#endif -} - -/* sm: interface to above from Ocaml */ -value sample_pentium_perfcount_20() -{ - return Val_long(sample_ppc_20()); -} - -value sample_pentium_perfcount_10() -{ - return Val_long(sample_ppc_10()); -} - -#endif - - -/* Now we have a function that tries to compute the number of cycles per - * second (to be used during ./configure) */ -#ifdef CONFIGURATION_ONLY -#include -#include -#include - -int main() { - struct tms t; - clock_t start, finish, diff; - unsigned longlong start_pc, finish_pc, diff_pc; - long clk_per_sec = sysconf(_SC_CLK_TCK); - double cycles_per_usec; - - if(clk_per_sec <= 0) { - printf("Cannot find clk_per_sec (got %ld)\n", clk_per_sec); - exit(1); - } - - times(&t); start = t.tms_utime; - start_pc = read_ppc(); - // Do something for a while - { - int i; - double a = 5.678; - for(i=0;i<10000000;i++) { - a = (i & 1) ? (a * a) : (sqrt(a)); - } - } - times(&t); finish = t.tms_utime; - finish_pc = read_ppc(); - diff = finish - start; - diff_pc = finish_pc - start_pc; - if(diff == 0) { - printf("Cannot use Unix.times\n"); - exit(1); - } - if(diff_pc == 0) { - printf("Invalid result from the peformance counters\n"); - exit(1); - } - diff_pc /= 1000000; // We care about cycles per microsecond -// printf("diff = %ld, diff_pc = %ld, clk = %ld\n", -// (long)diff, -// (long)diff_pc, (long)clk_per_sec); - - cycles_per_usec = (((double)diff_pc / (double)diff) - * (double)clk_per_sec); - - /* Whatever value we print here will be used as the CYCLES_PER_USEC - * below */ - printf("%.3lf\n", cycles_per_usec); - exit(0); -} -#endif //defined CONFIGURATION_ONLY - diff --git a/cil/ocamlutil/pretty.ml b/cil/ocamlutil/pretty.ml deleted file mode 100644 index 47d07ac..0000000 --- a/cil/ocamlutil/pretty.ml +++ /dev/null @@ -1,859 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(******************************************************************************) -(* Pretty printer - This module contains several fast, but sub-optimal heuristics to pretty-print - structured text. -*) - -let debug = false - -(* Choose an algorithm *) -type algo = George | Aman | Gap -let algo = George -let fastMode = ref false - - -(** Whether to print identation or not (for faster printing and smaller - * output) *) -let printIndent = ref true - -(******************************************************************************) -(* The doc type and constructors *) - -type doc = - Nil - | Text of string - | Concat of doc * doc - | CText of doc * string - | Break - | Line - | LeftFlush - | Align - | Unalign - | Mark - | Unmark - -(* Break a string at \n *) -let rec breakString (acc: doc) (str: string) : doc = - try - (* Printf.printf "breaking string %s\n" str; *) - let r = String.index str '\n' in - (* Printf.printf "r=%d\n" r; *) - let len = String.length str in - if r > 0 then begin - (* Printf.printf "Taking %s\n" (String.sub str 0 r); *) - let acc' = Concat(CText (acc, String.sub str 0 r), Line) in - if r = len - 1 then (* The last one *) - acc' - else begin - (* Printf.printf "Continuing with %s\n" (String.sub str (r + 1) (len - r - 1)); *) - breakString acc' - (String.sub str (r + 1) (len - r - 1)) - end - end else (* The first is a newline *) - breakString (Concat(acc, Line)) - (String.sub str (r + 1) (len - r - 1)) - with Not_found -> - if acc = Nil then Text str else CText (acc, str) - -let nil = Nil -let text s = breakString nil s -let num i = text (string_of_int i) -let real f = text (string_of_float f) -let chr c = text (String.make 1 c) -let align = Align -let unalign = Unalign -let line = Line -let leftflush = LeftFlush -let break = Break -let mark = Mark -let unmark = Unmark - -let d_int32 (i: int32) = text (Int32.to_string i) -let f_int32 () i = d_int32 i - -let d_int64 (i: int64) = text (Int64.to_string i) -let f_int64 () i = d_int64 i - - -(* Note that the ++ operator in Ocaml are left-associative. This means - * that if you have a long list of ++ then the whole thing is very unbalanced - * towards the left side. This is the worst possible case since scanning the - * left side of a Concat is the non-tail recursive case. *) - -let (++) d1 d2 = Concat (d1, d2) -let concat d1 d2 = Concat (d1, d2) - -(* Ben Liblit fix *) -let indent n d = text (String.make n ' ') ++ (align ++ (d ++ unalign)) - -let markup d = mark ++ d ++ unmark - -(* Format a sequence. The first argument is a separator *) -let seq ~(sep:doc) ~(doit:'a -> doc) ~(elements: 'a list) = - let rec loop (acc: doc) = function - [] -> acc - | h :: t -> - let fh = doit h in (* Make sure this is done first *) - loop (acc ++ sep ++ fh) t - in - (match elements with - [] -> nil - | h :: t -> - let fh = doit h in loop fh t) - - -let docArray ?(sep=chr ',') (doit:int -> 'a -> doc) () (elements:'a array) = - let len = Array.length elements in - if len = 0 then - nil - else - let rec loop (acc: doc) i = - if i >= len then acc else - let fi = doit i elements.(i) in (* Make sure this is done first *) - loop (acc ++ sep ++ fi) (i + 1) - in - let f0 = doit 0 elements.(0) in - loop f0 1 - -let docOpt delem () = function - None -> text "None" - | Some e -> text "Some(" ++ (delem e) ++ chr ')' - - - -let docList ?(sep=chr ',') (doit:'a -> doc) () (elements:'a list) = - seq sep doit elements - -let insert () d = d - - -let d_list (sep:string) (doit:unit -> 'a -> doc) () (elts:'a list) : doc = - (* thunk 'doit' to match docList's interface *) - let internalDoit (elt:'a) = - (doit () elt) in - (docList ~sep:(text sep) internalDoit () elts) - -(** Format maps *) -module MakeMapPrinter = - functor (Map: sig - type key - type 'a t - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - end) -> -struct - let docMap ?(sep=chr ',') - (doit: Map.key -> 'a -> doc) () (maplets: 'a Map.t) : doc = - Map.fold - (fun k d acc -> - (if acc==nil then acc else acc ++ sep) - ++ (doit k d)) - maplets - nil - - let dmaplet d0 d1 = d0 ++ (text " |-> ") ++ d1 - - let d_map ?(dmaplet=dmaplet) (sep:string) dkey dval = - let doit = fun k d -> dmaplet (dkey () k) (dval () d) in - docMap ~sep:(text sep) doit -end - -(** Format sets *) -module MakeSetPrinter = - functor (Set: sig - type elt - type t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - end) -> -struct - let docSet ?(sep=chr ',') (doit: Set.elt -> doc) () (set: Set.t) : doc = - Set.fold - (fun elt acc -> - (if acc==nil then acc else acc ++ sep) - ++ (doit elt)) - set - nil - - let d_set (sep:string) delt = - docSet ~sep:(text sep) (delt ()) -end - - -(******************************************************************************) -(* Some debugging stuff *) - -let dbgprintf x = Printf.fprintf stderr x - -let rec dbgPrintDoc = function - Nil -> dbgprintf "(Nil)" - | Text s -> dbgprintf "(Text %s)" s - | Concat (d1,d2) -> dbgprintf ""; dbgPrintDoc d1; dbgprintf " ++\n "; - dbgPrintDoc d2; dbgprintf "" - | CText (d,s) -> dbgPrintDoc d; dbgprintf " ++ \"%s\"" s; - | Break -> dbgprintf "(Break)" - | Line -> dbgprintf "(Line)" - | LeftFlush -> dbgprintf "(LeftFlush)" - | Align -> dbgprintf "(Align)" - | Unalign -> dbgprintf "(Unalign)" - | Mark -> dbgprintf "(Mark)" - | Unmark -> dbgprintf "(Unmark)" - -(******************************************************************************) -(* The "george" algorithm *) - -(* When we construct documents, most of the time they are heavily unbalanced - * towards the left. This is due to the left-associativity of ++ and also to - * the fact that constructors such as docList construct from the let of a - * sequence. We would prefer to shift the imbalance to the right to avoid - * consuming a lot of stack when we traverse the document *) -let rec flatten (acc: doc) = function - | Concat (d1, d2) -> flatten (flatten acc d2) d1 - | CText (d, s) -> flatten (Concat(Text s, acc)) d - | Nil -> acc (* Get rid of Nil *) - | d -> Concat(d, acc) - -(* We keep a stack of active aligns. *) -type align = - { mutable gainBreak: int; (* This is the gain that is associated with - * taking the break associated with this - * alignment mark. If this is 0, then there - * is no break associated with the mark *) - mutable isTaken: bool ref; (* If breakGain is > 0 then this is a ref - * cell that must be set to true when the - * break is taken. These ref cells are also - * int the "breaks" list *) - deltaFromPrev: int ref; (* The column of this alignment mark - - * the column of the previous mark. - * Shared with the deltaToNext of the - * previous active align *) - deltaToNext: int ref (* The column of the next alignment mark - - * the columns of this one. Shared with - * deltaFromPrev of the next active align *) - } - -(* We use references to avoid the need to pass data around all the time *) -let aligns: align list ref = (* The current stack of active alignment marks, - * with the top at the head. Never empty. *) - ref [{ gainBreak = 0; isTaken = ref false; - deltaFromPrev = ref 0; deltaToNext = ref 0; }] - -let topAlignAbsCol = ref 0 (* The absolute column of the top alignment *) - -let pushAlign (abscol: int) = - let topalign = List.hd !aligns in - let res = - { gainBreak = 0; isTaken = ref false; - deltaFromPrev = topalign.deltaToNext; (* Share with the previous *) - deltaToNext = ref 0; (* Allocate a new ref *)} in - aligns := res :: !aligns; - res.deltaFromPrev := abscol - !topAlignAbsCol; - topAlignAbsCol := abscol - -let popAlign () = - match !aligns with - top :: t when t != [] -> - aligns := t; - topAlignAbsCol := !topAlignAbsCol - !(top.deltaFromPrev) - | _ -> failwith "Unmatched unalign\n" - -(** We keep a list of active markup sections. For each one we keep the column - * we are in *) -let activeMarkups: int list ref = ref [] - - -(* Keep a list of ref cells for the breaks, in the same order that we see - * them in the document *) -let breaks: bool ref list ref = ref [] - -(* The maximum column that we should use *) -let maxCol = ref 0 - -(* Sometimes we take all the optional breaks *) -let breakAllMode = ref false - -(* We are taking a newline and moving left *) -let newline () = - let topalign = List.hd !aligns in (* aligns is never empty *) - if debug then - dbgprintf "Taking a newline: reseting gain of %d\n" topalign.gainBreak; - topalign.gainBreak <- 0; (* Erase the current break info *) - if !breakAllMode && !topAlignAbsCol < !maxCol then - breakAllMode := false; - !topAlignAbsCol (* This is the new column *) - - - -(* Choose the align with the best gain. We outght to find a better way to - * keep the aligns sorted, especially since they gain never changes (when the - * align is the top align) *) -let chooseBestGain () : align option = - let bestGain = ref 0 in - let rec loop (breakingAlign: align option) = function - [] -> breakingAlign - | a :: resta -> - if debug then dbgprintf "Looking at align with gain %d\n" a.gainBreak; - if a.gainBreak > !bestGain then begin - bestGain := a.gainBreak; - loop (Some a) resta - end else - loop breakingAlign resta - in - loop None !aligns - - -(* Another one that chooses the break associated with the current align only *) -let chooseLastGain () : align option = - let topalign = List.hd !aligns in - if topalign.gainBreak > 0 then Some topalign else None - -(* We have just advanced to a new column. See if we must take a line break *) -let movingRight (abscol: int) : int = - (* Keep taking the best break until we get back to the left of maxCol or no - * more are left *) - let rec tryAgain abscol = - if abscol <= !maxCol then abscol else - begin - if debug then - dbgprintf "Looking for a break to take in column %d\n" abscol; - (* Find the best gain there is out there *) - match if !fastMode then None else chooseBestGain () with - None -> begin - (* No breaks are available. Take all breaks from now on *) - breakAllMode := true; - if debug then - dbgprintf "Can't find any breaks\n"; - abscol - end - | Some breakingAlign -> begin - let topalign = List.hd !aligns in - let theGain = breakingAlign.gainBreak in - assert (theGain > 0); - if debug then dbgprintf "Taking break at %d. gain=%d\n" abscol theGain; - breakingAlign.isTaken := true; - breakingAlign.gainBreak <- 0; - if breakingAlign != topalign then begin - breakingAlign.deltaToNext := - !(breakingAlign.deltaToNext) - theGain; - topAlignAbsCol := !topAlignAbsCol - theGain - end; - tryAgain (abscol - theGain) - end - end - in - tryAgain abscol - - -(* Keep track of nested align in gprintf. Each gprintf format string must - * have properly nested align/unalign pairs. When the nesting depth surpasses - * !printDepth then we print ... and we skip until the matching unalign *) -let printDepth = ref 10000000 (* WRW: must see whole thing *) -let alignDepth = ref 0 - -let useAlignDepth = true - -(** Start an align. Return true if we ahve just passed the threshhold *) -let enterAlign () = - incr alignDepth; - useAlignDepth && !alignDepth = !printDepth + 1 - -(** Exit an align *) -let exitAlign () = - decr alignDepth - -(** See if we are at a low-enough align level (and we should be printing - * normally) *) -let shallowAlign () = - not useAlignDepth || !alignDepth <= !printDepth - - -(* Pass the current absolute column and compute the new column *) -let rec scan (abscol: int) (d: doc) : int = - match d with - Nil -> abscol - | Concat (d1, d2) -> scan (scan abscol d1) d2 - | Text s when shallowAlign () -> - let sl = String.length s in - if debug then - dbgprintf "Done string: %s from %d to %d\n" s abscol (abscol + sl); - movingRight (abscol + sl) - | CText (d, s) -> - let abscol' = scan abscol d in - if shallowAlign () then begin - let sl = String.length s in - if debug then - dbgprintf "Done string: %s from %d to %d\n" s abscol' (abscol' + sl); - movingRight (abscol' + sl) - end else - abscol' - - | Align -> - pushAlign abscol; - if enterAlign () then - movingRight (abscol + 3) (* "..." *) - else - abscol - - | Unalign -> exitAlign (); popAlign (); abscol - - | Line when shallowAlign () -> (* A forced line break *) - if !activeMarkups != [] then - failwith "Line breaks inside markup sections"; - newline () - - | LeftFlush when shallowAlign () -> (* Keep cursor left-flushed *) 0 - - | Break when shallowAlign () -> (* An optional line break. Always a space - * followed by an optional line break *) - if !activeMarkups != [] then - failwith "Line breaks inside markup sections"; - let takenref = ref false in - breaks := takenref :: !breaks; - let topalign = List.hd !aligns in (* aligns is never empty *) - if !breakAllMode then begin - takenref := true; - newline () - end else begin - (* If there was a previous break there it stays not taken, forever. - * So we overwrite it. *) - topalign.isTaken <- takenref; - topalign.gainBreak <- 1 + abscol - !topAlignAbsCol; - if debug then - dbgprintf "Registering a break at %d with gain %d\n" - (1 + abscol) topalign.gainBreak; - movingRight (1 + abscol) - end - - | Mark -> activeMarkups := abscol :: !activeMarkups; - abscol - - | Unmark -> begin - match !activeMarkups with - old :: rest -> activeMarkups := rest; - old - | [] -> failwith "Too many unmark" - end - - | _ -> (* Align level is too deep *) abscol - - -(** Keep a running counter of the newlines we are taking. You can read and - * reset this from user code, if you want *) -let countNewLines = ref 0 - -(* The actual function that takes a document and prints it *) -let emitDoc - (emitString: string -> int -> unit) (* emit a number of copies of a - * string *) - (d: doc) = - let aligns: int list ref = ref [0] in (* A stack of alignment columns *) - - let wantIndent = ref false in - (* Use this function to take a newline *) - (* AB: modified it to flag wantIndent. The actual indentation is done only - if leftflush is not encountered *) - let newline () = - match !aligns with - [] -> failwith "Ran out of aligns" - | x :: _ -> - emitString "\n" 1; - incr countNewLines; - wantIndent := true; - x - in - (* Print indentation if wantIndent was previously flagged ; reset this flag *) - let indentIfNeeded () = - if !printIndent && !wantIndent then ignore ( - match !aligns with - [] -> failwith "Ran out of aligns" - | x :: _ -> - if x > 0 then emitString " " x; - x); - wantIndent := false - in - (* A continuation passing style loop *) - let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit - (* the new column *) = - match d with - Nil -> cont abscol - | Concat (d1, d2) -> - loopCont abscol d1 (fun abscol' -> loopCont abscol' d2 cont) - - | Text s when shallowAlign () -> - let sl = String.length s in - indentIfNeeded (); - emitString s 1; - cont (abscol + sl) - - | CText (d, s) -> - loopCont abscol d - (fun abscol' -> - if shallowAlign () then - let sl = String.length s in - indentIfNeeded (); - emitString s 1; - cont (abscol' + sl) - else - cont abscol') - - | Align -> - aligns := abscol :: !aligns; - if enterAlign () then begin - indentIfNeeded (); - emitString "..." 1; - cont (abscol + 3) - end else - cont abscol - - | Unalign -> begin - match !aligns with - [] -> failwith "Unmatched unalign" - | _ :: rest -> - exitAlign (); - aligns := rest; cont abscol - end - | Line when shallowAlign () -> cont (newline ()) - | LeftFlush when shallowAlign () -> wantIndent := false; cont (0) - | Break when shallowAlign () -> begin - match !breaks with - [] -> failwith "Break without a takenref" - | istaken :: rest -> - breaks := rest; (* Consume the break *) - if !istaken then cont (newline ()) - else begin - indentIfNeeded (); - emitString " " 1; - cont (abscol + 1) - end - end - - | Mark -> - activeMarkups := abscol :: !activeMarkups; - cont abscol - - | Unmark -> begin - match !activeMarkups with - old :: rest -> activeMarkups := rest; - cont old - | [] -> failwith "Unmark without a mark" - end - - | _ -> (* Align is too deep *) - cont abscol - in - - loopCont 0 d (fun x -> ()) - - -(* Print a document on a channel *) -let fprint (chn: out_channel) ~(width: int) doc = - (* Save some parameters, to allow for nested calls of these routines. *) - maxCol := width; - let old_breaks = !breaks in - breaks := []; - let old_alignDepth = !alignDepth in - alignDepth := 0; - let old_activeMarkups = !activeMarkups in - activeMarkups := []; - ignore (scan 0 doc); - breaks := List.rev !breaks; - ignore (emitDoc - (fun s nrcopies -> - for i = 1 to nrcopies do - output_string chn s - done) doc); - activeMarkups := old_activeMarkups; - alignDepth := old_alignDepth; - breaks := old_breaks (* We must do this especially if we don't do emit - * (which consumes breaks) because otherwise we waste - * memory *) - -(* Print the document to a string *) -let sprint ~(width : int) doc : string = - maxCol := width; - let old_breaks = !breaks in - breaks := []; - let old_activeMarkups = !activeMarkups in - activeMarkups := []; - let old_alignDepth = !alignDepth in - alignDepth := 0; - ignore (scan 0 doc); - breaks := List.rev !breaks; - let buf = Buffer.create 1024 in - let rec add_n_strings str num = - if num <= 0 then () - else begin Buffer.add_string buf str; add_n_strings str (num - 1) end - in - emitDoc add_n_strings doc; - breaks := old_breaks; - activeMarkups := old_activeMarkups; - alignDepth := old_alignDepth; - Buffer.contents buf - - - (* The rest is based on printf.ml *) -external format_int: string -> int -> string = "caml_format_int" -external format_float: string -> float -> string = "caml_format_float" - - - -let gprintf (finish : doc -> 'b) - (format : ('a, unit, doc, 'b) format4) : 'a = - let format = (Obj.magic format : string) in - - (* Record the starting align depth *) - let startAlignDepth = !alignDepth in - (* Special concatenation functions *) - let dconcat (acc: doc) (another: doc) = - if !alignDepth > !printDepth then acc else acc ++ another in - let dctext1 (acc: doc) (str: string) = - if !alignDepth > !printDepth then acc else - CText(acc, str) - in - (* Special finish function *) - let dfinish (dc: doc) : 'b = - if !alignDepth <> startAlignDepth then - prerr_string ("Unmatched align/unalign in " ^ format ^ "\n"); - finish dc - in - let flen = String.length format in - (* Reading a format character *) - let fget = String.unsafe_get format in - (* Output a literal sequence of - * characters, starting at i. The - * character at i does not need to be - * checked. *) - let rec literal acc i = - let rec skipChars j = - if j >= flen || - (match fget j with - '%' -> true - | '@' -> true - | '\n' -> true - | _ -> false) then - collect (dctext1 acc (String.sub format i (j-i))) j - else - skipChars (succ j) - in - skipChars (succ i) - (* the main collection function *) - and collect (acc: doc) (i: int) = - if i >= flen then begin - Obj.magic (dfinish acc) - end else begin - let c = fget i in - if c = '%' then begin - let j = skip_args (succ i) in - match fget j with - '%' -> literal acc j - | 's' -> - Obj.magic(fun s -> - let str = - if j <= i+1 then - s - else - let sl = String.length s in - let p = - try - int_of_string (String.sub format (i+1) (j-i-1)) - with _ -> - invalid_arg "fprintf: bad %s format" in - if p > 0 && sl < p then - (String.make (p - sl) ' ') ^ s - else if p < 0 && sl < -p then - s ^ (String.make (-p - sl) ' ') - else - s - in - collect (breakString acc str) (succ j)) - | 'c' -> - Obj.magic(fun c -> - collect (dctext1 acc (String.make 1 c)) (succ j)) - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> - Obj.magic(fun n -> - collect (dctext1 acc - (format_int (String.sub format i - (j-i+1)) n)) - (succ j)) - (* L, l, and n are the Int64, Int32, and Nativeint modifiers to the integer - formats d,i,o,x,X,u. For example, %Lo means print an Int64 in octal.*) - | 'L' -> - if j != i + 1 then (*Int64.format handles simple formats like %d. - * Any special flags eaten by skip_args will confuse it. *) - invalid_arg ("dprintf: unimplemented format " - ^ (String.sub format i (j-i+1))); - let j' = succ j in (* eat the d,i,x etc. *) - let format_spec = "% " in - String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) - Obj.magic(fun n -> - collect (dctext1 acc - (Int64.format format_spec n)) - (succ j')) - | 'l' -> - if j != i + 1 then invalid_arg ("dprintf: unimplemented format " - ^ (String.sub format i (j-i+1))); - let j' = succ j in (* eat the d,i,x etc. *) - let format_spec = "% " in - String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) - Obj.magic(fun n -> - collect (dctext1 acc - (Int32.format format_spec n)) - (succ j')) - | 'n' -> - if j != i + 1 then invalid_arg ("dprintf: unimplemented format " - ^ (String.sub format i (j-i+1))); - let j' = succ j in (* eat the d,i,x etc. *) - let format_spec = "% " in - String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) - Obj.magic(fun n -> - collect (dctext1 acc - (Nativeint.format format_spec n)) - (succ j')) - | 'f' | 'e' | 'E' | 'g' | 'G' -> - Obj.magic(fun f -> - collect (dctext1 acc - (format_float (String.sub format i (j-i+1)) f)) - (succ j)) - | 'b' | 'B' -> - Obj.magic(fun b -> - collect (dctext1 acc (string_of_bool b)) (succ j)) - | 'a' -> - Obj.magic(fun pprinter arg -> - collect (dconcat acc (pprinter () arg)) (succ j)) - | 't' -> - Obj.magic(fun pprinter -> - collect (dconcat acc (pprinter ())) (succ j)) - | c -> - invalid_arg ("dprintf: unknown format %s" ^ String.make 1 c) - - end else if c = '@' then begin - if i + 1 < flen then begin - match fget (succ i) with - - (* Now the special format characters *) - '[' -> (* align *) - let newacc = - if !alignDepth > !printDepth then - acc - else if !alignDepth = !printDepth then - CText(acc, "...") - else - acc ++ align - in - incr alignDepth; - collect newacc (i + 2) - - | ']' -> (* unalign *) - decr alignDepth; - let newacc = - if !alignDepth >= !printDepth then - acc - else - acc ++ unalign - in - collect newacc (i + 2) - | '!' -> (* hard-line break *) - collect (dconcat acc line) (i + 2) - | '?' -> (* soft line break *) - collect (dconcat acc (break)) (i + 2) - | '<' -> - collect (dconcat acc mark) (i +1) - | '>' -> - collect (dconcat acc unmark) (i +1) - | '^' -> (* left-flushed *) - collect (dconcat acc (leftflush)) (i + 2) - | '@' -> - collect (dctext1 acc "@") (i + 2) - | c -> - invalid_arg ("dprintf: unknown format @" ^ String.make 1 c) - end else - invalid_arg "dprintf: incomplete format @" - end else if c = '\n' then begin - collect (dconcat acc line) (i + 1) - end else - literal acc i - end - - and skip_args j = - match String.unsafe_get format j with - '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j) - | c -> j - - in - collect Nil 0 - -let withPrintDepth dp thunk = - let opd = !printDepth in - printDepth := dp; - thunk (); - printDepth := opd - - - -let flushOften = ref false - -let dprintf format = gprintf (fun x -> x) format -let fprintf chn format = - let f d = fprint chn 80 d; d in - (* weimeric hack begins -- flush output to streams *) - let res = gprintf f format in - (* save the value we would have returned, flush the channel and then - * return it -- this allows us to see debug input near infinite loops - * *) - if !flushOften then flush chn; - res - (* weimeric hack ends *) - -let printf format = fprintf stdout format -let eprintf format = fprintf stderr format - - - -(******************************************************************************) -let getAlgoName = function - George -> "George" - | Aman -> "Aman" - | Gap -> "Gap" - -let getAboutString () : string = - "(Pretty: ALGO=" ^ (getAlgoName algo) ^ ")" - - -(************************************************) -let auto_printer (typ: string) = - failwith ("Pretty.auto_printer \"" ^ typ ^ "\" only works with you use -pp \"camlp4o pa_prtype.cmo\" when you compile") diff --git a/cil/ocamlutil/pretty.mli b/cil/ocamlutil/pretty.mli deleted file mode 100644 index 5422432..0000000 --- a/cil/ocamlutil/pretty.mli +++ /dev/null @@ -1,316 +0,0 @@ -(* - * - * Copyright (c) 2001 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** Utility functions for pretty-printing. The major features provided by - this module are -- An [fprintf]-style interface with support for user-defined printers -- The printout is fit to a width by selecting some of the optional newlines -- Constructs for alignment and indentation -- Print ellipsis starting at a certain nesting depth -- Constructs for printing lists and arrays - - Pretty-printing occurs in two stages: -- Construct a {!Pretty.doc} object that encodes all of the elements to be - printed - along with alignment specifiers and optional and mandatory newlines -- Format the {!Pretty.doc} to a certain width and emit it as a string, to an - output stream or pass it to a user-defined function - - The formatting algorithm is not optimal but it does a pretty good job while - still operating in linear time. The original version was based on a pretty - printer by Philip Wadler which turned out to not scale to large jobs. -*) - -(** API *) - -(** The type of unformated documents. Elements of this type can be - * constructed in two ways. Either with a number of constructor shown below, - * or using the {!Pretty.dprintf} function with a [printf]-like interface. - * The {!Pretty.dprintf} method is slightly slower so we do not use it for - * large jobs such as the output routines for a compiler. But we use it for - * small jobs such as logging and error messages. *) -type doc - - - -(** Constructors for the doc type. *) - - - - -(** Constructs an empty document *) -val nil : doc - - -(** Concatenates two documents. This is an infix operator that associates to - the left. *) -val (++) : doc -> doc -> doc -val concat : doc -> doc -> doc - -(** A document that prints the given string *) -val text : string -> doc - - -(** A document that prints an integer in decimal form *) -val num : int -> doc - - -(** A document that prints a real number *) -val real : float -> doc - -(** A document that prints a character. This is just like {!Pretty.text} - with a one-character string. *) -val chr : char -> doc - - -(** A document that consists of a mandatory newline. This is just like [(text - "\n")]. The new line will be indented to the current indentation level, - unless you use {!Pretty.leftflush} right after this. *) -val line : doc - -(** Use after a {!Pretty.line} to prevent the indentation. Whatever follows - * next will be flushed left. Indentation resumes on the next line. *) -val leftflush : doc - - -(** A document that consists of either a space or a line break. Also called - an optional line break. Such a break will be - taken only if necessary to fit the document in a given width. If the break - is not taken a space is printed instead. *) -val break: doc - -(** Mark the current column as the current indentation level. Does not print - anything. All taken line breaks will align to this column. The previous - alignment level is saved on a stack. *) -val align: doc - -(** Reverts to the last saved indentation level. *) -val unalign: doc - - -(** Mark the beginning of a markup section. The width of a markup section is - * considered 0 for the purpose of computing identation *) -val mark: doc - -(** The end of a markup section *) -val unmark: doc - -(************* Now some syntactic sugar *****************) -(** Syntactic sugar *) - -(** Indents the document. Same as [((text " ") ++ align ++ doc ++ unalign)], - with the specified number of spaces. *) -val indent: int -> doc -> doc - -(** Prints a document as markup. The marked document cannot contain line - * breaks or alignment constructs. *) -val markup: doc -> doc - -(** Formats a sequence. [sep] is a separator, [doit] is a function that - * converts an element to a document. *) -val seq: sep:doc -> doit:('a ->doc) -> elements:'a list -> doc - - -(** An alternative function for printing a list. The [unit] argument is there - * to make this function more easily usable with the {!Pretty.dprintf} - * interface. The first argument is a separator, by default a comma. *) -val docList: ?sep:doc -> ('a -> doc) -> unit -> 'a list -> doc - -(** sm: Yet another list printer. This one accepts the same kind of - * printing function that {!Pretty.dprintf} does, and itself works - * in the dprintf context. Also accepts - * a string as the separator since that's by far the most common. *) -val d_list: string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc - -(** Formats an array. A separator and a function that prints an array - element. The default separator is a comma. *) -val docArray: ?sep:doc -> (int -> 'a -> doc) -> unit -> 'a array -> doc - -(** Prints an ['a option] with [None] or [Some] *) -val docOpt: ('a -> doc) -> unit -> 'a option -> doc - - -(** Print an int32 *) -val d_int32: int32 -> doc -val f_int32: unit -> int32 -> doc - -val d_int64: int64 -> doc -val f_int64: unit -> int64 -> doc - -(** Format maps. *) -module MakeMapPrinter : - functor (Map: sig - type key - type 'a t - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - end) -> -sig - (** Format a map, analogous to docList. *) - val docMap: ?sep:doc -> (Map.key -> 'a -> doc) -> unit -> 'a Map.t -> doc - - (** Format a map, analogous to d_list. *) - val d_map: ?dmaplet:(doc -> doc -> doc) - -> string - -> (unit -> Map.key -> doc) - -> (unit -> 'a -> doc) - -> unit - -> 'a Map.t - -> doc - end - -(** Format sets. *) -module MakeSetPrinter : - functor (Set: sig - type elt - type t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - end) -> -sig - (** Format a set, analogous to docList. *) - val docSet: ?sep:doc -> (Set.elt -> doc) -> unit -> Set.t -> doc - - (** Format a set, analogous to d_list. *) - val d_set: string - -> (unit -> Set.elt -> doc) - -> unit - -> Set.t - -> doc -end - -(** A function that is useful with the [printf]-like interface *) -val insert: unit -> doc -> doc - -val dprintf: ('a, unit, doc, doc) format4 -> 'a -(** This function provides an alternative method for constructing - [doc] objects. The first argument for this function is a format string - argument (of type [('a, unit, doc) format]; if you insist on - understanding what that means see the module [Printf]). The format string - is like that for the [printf] function in C, except that it understands a - few more formatting controls, all starting with the @ character. - - See the gprintf function if you want to pipe the result of dprintf into - some other functions. - - The following special formatting characters are understood (these do not - correspond to arguments of the function): -- @\[ Inserts an {!Pretty.align}. Every format string must have matching - {!Pretty.align} and {!Pretty.unalign}. -- @\] Inserts an {!Pretty.unalign}. -- @! Inserts a {!Pretty.line}. Just like "\n" -- @? Inserts a {!Pretty.break}. -- @< Inserts a {!Pretty.mark}. -- @> Inserts a {!Pretty.unmark}. -- @^ Inserts a {!Pretty.leftflush} - Should be used immediately after @! or "\n". -- @@ : inserts a @ character - - In addition to the usual [printf] % formatting characters the following two - new characters are supported: -- %t Corresponds to an argument of type [unit -> doc]. This argument is - invoked to produce a document -- %a Corresponds to {b two} arguments. The first of type [unit -> 'a -> doc] - and the second of type ['a]. (The extra [unit] is do to the - peculiarities of the built-in support for format strings in Ocaml. It - turns out that it is not a major problem.) Here is an example of how - you use this: - -{v dprintf "Name=%s, SSN=%7d, Children=\@\[%a\@\]\n" - pers.name pers.ssn (docList (chr ',' ++ break) text) - pers.children v} - - The result of [dprintf] is a {!Pretty.doc}. You can format the document and - emit it using the functions {!Pretty.fprint} and {!Pretty.sprint}. - -*) - -(** Like {!Pretty.dprintf} but more general. It also takes a function that is - * invoked on the constructed document but before any formatting is done. The - * type of the format argument means that 'a is the type of the parameters of - * this function, unit is the type of the first argument to %a and %t - * formats, doc is the type of the intermediate result, and 'b is the type of - * the result of gprintf. *) -val gprintf: (doc -> 'b) -> ('a, unit, doc, 'b) format4 -> 'a - -(** Format the document to the given width and emit it to the given channel *) -val fprint: out_channel -> width:int -> doc -> unit - -(** Format the document to the given width and emit it as a string *) -val sprint: width:int -> doc -> string - -(** Like {!Pretty.dprintf} followed by {!Pretty.fprint} *) -val fprintf: out_channel -> ('a, unit, doc) format -> 'a - -(** Like {!Pretty.fprintf} applied to [stdout] *) -val printf: ('a, unit, doc) format -> 'a - -(** Like {!Pretty.fprintf} applied to [stderr] *) -val eprintf: ('a, unit, doc) format -> 'a - - -(* sm: arg! why can't I write this function?! *) -(* * Like {!Pretty.dprintf} but yielding a string with no newlines *) -(*val sprintf: (doc, unit, doc) format -> string*) - -(* sm: different tack.. *) -(* doesn't work either. well f it anyway *) -(*val failwithf: ('a, unit, doc) format -> 'a*) - - -(** Invokes a thunk, with printDepth temporarily set to the specified value *) -val withPrintDepth : int -> (unit -> unit) -> unit - -(** The following variables can be used to control the operation of the printer *) - -(** Specifies the nesting depth of the [align]/[unalign] pairs at which - everything is replaced with ellipsis *) -val printDepth : int ref - -val printIndent : bool ref (** If false then does not indent *) - - -(** If set to [true] then optional breaks are taken only when the document - has exceeded the given width. This means that the printout will looked - more ragged but it will be faster *) -val fastMode : bool ref - -val flushOften : bool ref (** If true the it flushes after every print *) - - -(** Keep a running count of the taken newlines. You can read and write this - * from the client code if you want *) -val countNewLines : int ref - - -(** A function that when used at top-level in a module will direct - * the pa_prtype module generate automatically the printing functions for a - * type *) -val auto_printer: string -> 'b diff --git a/cil/ocamlutil/stats.ml b/cil/ocamlutil/stats.ml deleted file mode 100644 index 8bbb7d0..0000000 --- a/cil/ocamlutil/stats.ml +++ /dev/null @@ -1,146 +0,0 @@ -(* The following functions are implemented in perfcount.c *) - -(* Returns true is we have the performance counters *) -external has_performance_counters: unit -> bool = "has_performance_counters" - -(* Returns number of seconds since the first read *) -external read_pentium_perfcount : unit -> float = "read_pentium_perfcount" - -(* Returns current cycle counter, divided by 1^20, and truncated to 30 bits *) -external sample_pentium_perfcount_20 : unit -> int = "sample_pentium_perfcount_20" - -(* Returns current cycle counter, divided by 1^10, and truncated to 30 bits *) -external sample_pentium_perfcount_10 : unit -> int = "sample_pentium_perfcount_10" - - -(* Whether to use the performance counters (on Pentium only) *) - -(* The performance counters are disabled by default. *) -let do_use_performance_counters = ref false - - (* A hierarchy of timings *) - -type t = { name : string; - mutable time : float; (* In seconds *) - mutable sub : t list} - - (* Create the top level *) -let top = { name = "TOTAL"; - time = 0.0; - sub = []; } - - (* The stack of current path through - * the hierarchy. The first is the - * leaf. *) -let current : t list ref = ref [top] - -exception NoPerfCount -let reset (perfcount: bool) = - top.sub <- []; - if perfcount then begin - if not (has_performance_counters ()) then begin - raise NoPerfCount - end - end; - do_use_performance_counters := perfcount - - - -let print chn msg = - (* Total up *) - top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub; - let rec prTree ind node = - if !do_use_performance_counters then - (Printf.fprintf chn "%s%-20s %8.5f s\n" - (String.make ind ' ') node.name node.time) - else - (Printf.fprintf chn "%s%-20s %6.3f s\n" - (String.make ind ' ') node.name node.time); - - List.iter (prTree (ind + 2)) (List.rev node.sub) - in - Printf.fprintf chn "%s" msg; - List.iter (prTree 0) [ top ]; - Printf.fprintf chn "Timing used %s\n" - (if !do_use_performance_counters then "Pentium performance counters" - else "Unix.time"); - let gc = Gc.quick_stat () in - let printM (w: float) : string = - Printf.sprintf "%.2fMb" (w *. 4.0 /. 1000000.0) - in - Printf.fprintf chn - "Memory statistics: total=%s, max=%s, minor=%s, major=%s, promoted=%s\n minor collections=%d major collections=%d compactions=%d\n" - (printM (gc.Gc.minor_words +. gc.Gc.major_words - -. gc.Gc.promoted_words)) - (printM (float_of_int gc.Gc.top_heap_words)) - (printM gc.Gc.minor_words) - (printM gc.Gc.major_words) - (printM gc.Gc.promoted_words) - gc.Gc.minor_collections - gc.Gc.major_collections - gc.Gc.compactions; - - () - - - -(* Get the current time, in seconds *) -let get_current_time () : float = - if !do_use_performance_counters then - read_pentium_perfcount () - else - (Unix.times ()).Unix.tms_utime - -let repeattime limit str f arg = - (* Find the right stat *) - let stat : t = - let curr = match !current with h :: _ -> h | _ -> assert false in - let rec loop = function - h :: _ when h.name = str -> h - | _ :: rest -> loop rest - | [] -> - let nw = {name = str; time = 0.0; sub = []} in - curr.sub <- nw :: curr.sub; - nw - in - loop curr.sub - in - let oldcurrent = !current in - current := stat :: oldcurrent; - let start = get_current_time () in - let rec repeatf count = - let res = f arg in - let diff = get_current_time () -. start in - if diff < limit then - repeatf (count + 1) - else begin - stat.time <- stat.time +. (diff /. float(count)); - current := oldcurrent; (* Pop the current stat *) - res (* Return the function result *) - end - in - repeatf 1 - - -let time str f arg = repeattime 0.0 str f arg - - -let lastTime = ref 0.0 -let timethis (f: 'a -> 'b) (arg: 'a) : 'b = - let start = get_current_time () in - let res = f arg in - lastTime := get_current_time () -. start; - res - - - - - - - - - - - - - diff --git a/cil/ocamlutil/stats.mli b/cil/ocamlutil/stats.mli deleted file mode 100644 index 9ed98e5..0000000 --- a/cil/ocamlutil/stats.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* - * - * Copyright (c) 2001 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** Utilities for maintaining timing statistics *) - -(** Resets all the timings. Invoke with "true" if you want to switch to using - * the hardware performance counters from now on. You get an exception if - * there are not performance counters available *) -val reset: bool -> unit -exception NoPerfCount - -(** Check if we have performance counters *) -val has_performance_counters: unit -> bool - -(** Sample the current cycle count, in megacycles. *) -val sample_pentium_perfcount_20: unit -> int - -(** Sample the current cycle count, in kilocycles. *) -val sample_pentium_perfcount_10: unit -> int - -(** Time a function and associate the time with the given string. If some - timing information is already associated with that string, then accumulate - the times. If this function is invoked within another timed function then - you can have a hierarchy of timings *) -val time : string -> ('a -> 'b) -> 'a -> 'b - -(** repeattime is like time but runs the function several times until the total - running time is greater or equal to the first argument. The total time is - then divided by the number of times the function was run. *) -val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b - -(** Print the current stats preceeded by a message *) -val print : out_channel -> string -> unit - - - -(** Time a function and set lastTime to the time it took *) -val lastTime: float ref -val timethis: ('a -> 'b) -> 'a -> 'b - - - - diff --git a/cil/ocamlutil/trace.ml b/cil/ocamlutil/trace.ml deleted file mode 100644 index b429286..0000000 --- a/cil/ocamlutil/trace.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Trace module implementation - * see trace.mli - *) - -open Pretty;; - - -(* --------- traceSubsystems --------- *) -(* this is the list of tags (usually subsystem names) for which - * trace output will appear *) -let traceSubsystems : string list ref = ref [];; - - -let traceAddSys (subsys : string) : unit = - (* (ignore (printf "traceAddSys %s\n" subsys)); *) - traceSubsystems := subsys :: !traceSubsystems -;; - - -let traceActive (subsys : string) : bool = - (* (List.mem elt list) returns true if something in list equals ('=') elt *) - (List.mem subsys !traceSubsystems) -;; - - -let rec parseString (str : string) (delim : char) : string list = -begin - if (not (String.contains str delim)) then - if ((String.length str) = 0) then - [] - else - [str] - - else - let d = ((String.index str delim) + 1) in - if (d = 1) then - (* leading delims are eaten *) - (parseString (String.sub str d ((String.length str) - d)) delim) - else - (String.sub str 0 (d-1)) :: - (parseString (String.sub str d ((String.length str) - d)) delim) -end;; - -let traceAddMulti (systems : string) : unit = -begin - let syslist = (parseString systems ',') in - (List.iter traceAddSys syslist) -end;; - - - -(* --------- traceIndent --------- *) -let traceIndentLevel : int ref = ref 0;; - - -let traceIndent (sys : string) : unit = - if (traceActive sys) then - traceIndentLevel := !traceIndentLevel + 2 -;; - -let traceOutdent (sys : string) : unit = - if ((traceActive sys) && - (!traceIndentLevel >= 2)) then - traceIndentLevel := !traceIndentLevel - 2 -;; - - -(* --------- trace --------- *) -(* return a tag to prepend to a trace output - * e.g. " %%% mysys: " - *) -let traceTag (sys : string) : Pretty.doc = - (* return string of 'i' spaces *) - let rec ind (i : int) : string = - if (i <= 0) then - "" - else - " " ^ (ind (i-1)) - - in - (text ((ind !traceIndentLevel) ^ "%%% " ^ sys ^ ": ")) -;; - - -(* this is the trace function; its first argument is a string - * tag, and subsequent arguments are like printf formatting - * strings ("%a" and whatnot) *) -let trace - (subsys : string) (* subsystem identifier for enabling tracing *) - (d : Pretty.doc) (* something made by 'dprintf' *) - : unit = (* no return value *) - (* (ignore (printf "trace %s\n" subsys)); *) - - (* see if the subsystem's tracing is turned on *) - if (traceActive subsys) then - begin - (fprint stderr 80 (* print it *) - ((traceTag subsys) ++ d)); (* with prepended subsys tag *) - (* mb: flush after every message; useful if the program hangs in an - infinite loop... *) - (flush stderr) - end - else - () (* eat it *) -;; - - -let tracei (sys : string) (d : Pretty.doc) : unit = - (* trace before indent *) - (trace sys d); - (traceIndent sys) -;; - -let traceu (sys : string) (d : Pretty.doc) : unit = - (* trace after outdent *) - (* no -- I changed my mind -- I want trace *then* outdent *) - (trace sys d); - (traceOutdent sys) -;; - - - - -(* -------------------------- trash --------------------- *) -(* TRASH START - -(* sm: more experimenting *) -(trace "no" (dprintf "no %d\n" 5)); -(trace "yes" (dprintf "yes %d\n" 6)); -(trace "maybe" (dprintf "maybe %d\n" 7)); - -TRASH END *) diff --git a/cil/ocamlutil/trace.mli b/cil/ocamlutil/trace.mli deleted file mode 100644 index 46ca652..0000000 --- a/cil/ocamlutil/trace.mli +++ /dev/null @@ -1,106 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Trace module - * Scott McPeak, 5/4/00 - * - * The idea is to pepper the source with debugging printfs, - * and be able to select which ones to actually display at - * runtime. - * - * It is built on top of the Pretty module for printing data - * structures. - * - * To a first approximation, this is needed to compensate for - * the lack of a debugger that does what I want... - *) - - -(* this is the list of tags (usually subsystem names) for which - * trace output will appear *) -val traceSubsystems : string list ref - -(* interface to add a new subsystem to trace (slightly more - * convenient than direclty changing 'tracingSubsystems') *) -val traceAddSys : string -> unit - -(* query whether a particular subsystem is being traced *) -val traceActive : string -> bool - -(* add several systems, separated by commas *) -val traceAddMulti : string -> unit - - -(* current indentation level for tracing *) -val traceIndentLevel : int ref - -(* bump up or down the indentation level, if the given subsys - * is being traced *) -val traceIndent : string -> unit -val traceOutdent : string -> unit - - -(* this is the trace function; its first argument is a string - * tag, and second argument is a 'doc' (which is what 'dprintf' - * returns). - * - * so a sample usage might be - * (trace "mysubsys" (dprintf "something neat happened %d times\n" counter)) - *) -val trace : string -> Pretty.doc -> unit - - -(* special flavors that indent/outdent as well. the indent version - * indents *after* printing, while the outdent version outdents - * *before* printing. thus, a sequence like - * - * (tracei "foo" (dprintf "beginning razzle-dazzle\n")) - * ..razzle.. - * ..dazzle.. - * (traceu "foo" (dprintf "done with razzle-dazzle\n")) - * - * will do the right thing - * - * update -- I changed my mind! I decided I prefer it like this - * %%% sys: (myfunc args) - * %%% ...inner stuff... - * %%% sys: myfunc returning 56 - * - * so now they both print before in/outdenting - *) -val tracei : string -> Pretty.doc -> unit -val traceu : string -> Pretty.doc -> unit diff --git a/cil/ocamlutil/util.ml b/cil/ocamlutil/util.ml deleted file mode 100755 index e6c2c67..0000000 --- a/cil/ocamlutil/util.ml +++ /dev/null @@ -1,815 +0,0 @@ -(** Utility functions for Coolaid *) -module E = Errormsg -module H = Hashtbl -module IH = Inthash - -open Pretty - -exception GotSignal of int - -let withTimeout (secs: float) (* Seconds for timeout *) - (handler: int -> 'b) (* What to do if we have a timeout. The - * argument passed is the signal number - * received. *) - (f: 'a -> 'b) (* The function to run *) - (arg: 'a) (* And its argument *) - : 'b = - let oldHandler = - Sys.signal Sys.sigalrm - (Sys.Signal_handle - (fun i -> - ignore (E.log "Got signal %d\n" i); - raise (GotSignal i))) - in - let reset_sigalrm () = - ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.0; - Unix.it_interval = 0.0;}); - Sys.set_signal Sys.sigalrm oldHandler; - in - ignore (Unix.setitimer Unix.ITIMER_REAL - { Unix.it_value = secs; - Unix.it_interval = 0.0;}); - (* ignore (Unix.alarm 2); *) - try - let res = f arg in - reset_sigalrm (); - res - with exc -> begin - reset_sigalrm (); - ignore (E.log "Got an exception\n"); - match exc with - GotSignal i -> - handler i - | _ -> raise exc - end - -(** Print a hash table *) -let docHash ?(sep=chr ',') (one: 'a -> 'b -> doc) () (h: ('a, 'b) H.t) = - (H.fold - (fun key data acc -> - if acc == align then acc ++ one key data - else acc ++ sep ++ one key data) - h - align) ++ unalign - - - -let hash_to_list (h: ('a, 'b) H.t) : ('a * 'b) list = - H.fold - (fun key data acc -> (key, data) :: acc) - h - [] - -let keys (h: ('a, 'b) H.t) : 'a list = - H.fold - (fun key data acc -> key :: acc) - h - [] - -let hash_copy_into (hfrom: ('a, 'b) H.t) (hto: ('a, 'b) H.t) : unit = - H.clear hto; - H.iter (H.add hto) hfrom - -let anticompare a b = compare b a -;; - - -let rec list_drop (n : int) (xs : 'a list) : 'a list = - if n < 0 then invalid_arg "Util.list_drop"; - if n = 0 then - xs - else begin - match xs with - | [] -> invalid_arg "Util.list_drop" - | y::ys -> list_drop (n-1) ys - end - -let list_droptail (n : int) (xs : 'a list) : 'a list = - if n < 0 then invalid_arg "Util.list_droptail"; - let (ndrop,r) = - List.fold_right - (fun x (ndrop,acc) -> - if ndrop = 0 then (ndrop, x :: acc) - else (ndrop-1, acc)) - xs - (n,[]) - in - if ndrop > 0 then invalid_arg "Util.listdroptail" - else r - -let rec list_span (p : 'a -> bool) (xs : 'a list) : 'a list * 'a list = - begin match xs with - | [] -> ([],[]) - | x::xs' -> - if p x then - let (ys,zs) = list_span p xs' in (x::ys,zs) - else ([],xs) - end -;; - -let rec list_rev_append revxs ys = - begin match revxs with - | [] -> ys - | x::xs -> list_rev_append xs (x::ys) - end -;; -let list_insert_by (cmp : 'a -> 'a -> int) - (x : 'a) (xs : 'a list) : 'a list = - let rec helper revhs ts = - begin match ts with - | [] -> List.rev (x::revhs) - | t::ts' -> - if cmp x t >= 0 then helper (t::revhs) ts' - else list_rev_append (x::revhs) ts - end - in - helper [] xs -;; - -let list_head_default (d : 'a) (xs : 'a list) : 'a = - begin match xs with - | [] -> d - | x::_ -> x - end -;; - -let rec list_iter3 f xs ys zs = - begin match xs, ys, zs with - | [], [], [] -> () - | x::xs, y::ys, z::zs -> f x y z; list_iter3 f xs ys zs - | _ -> invalid_arg "Util.list_iter3" - end -;; - -let rec get_some_option_list (xs : 'a option list) : 'a list = - begin match xs with - | [] -> [] - | None::xs -> get_some_option_list xs - | Some x::xs -> x :: get_some_option_list xs - end -;; - -(* tail-recursive append: reverses xs twice *) -let list_append (xs: 'a list) (ys: 'a list): 'a list = - match xs with (* optimize some common cases *) - [] -> ys - | [x] -> x::ys - | _ -> list_rev_append (List.rev xs) ys - -let list_iteri (f: int -> 'a -> unit) (l: 'a list) : unit = - let rec loop (i: int) (l: 'a list) : unit = - match l with - [] -> () - | h :: t -> f i h; loop (i + 1) t - in - loop 0 l - -let list_mapi (f: int -> 'a -> 'b) (l: 'a list) : 'b list = - let rec loop (i: int) (l: 'a list) : 'b list = - match l with - [] -> [] - | h :: t -> - let headres = f i h in - headres :: loop (i + 1) t - in - loop 0 l - -let list_fold_lefti (f: 'acc -> int -> 'a -> 'acc) (start: 'acc) - (l: 'a list) : 'acc = - let rec loop (i, acc) l = - match l with - [] -> acc - | h :: t -> loop (i + 1, f acc i h) t - in - loop (0, start) l - - -let list_init (len : int) (init_fun : int -> 'a) : 'a list = - let rec loop n acc = - if n < 0 then acc - else loop (n-1) ((init_fun n)::acc) - in - loop (len - 1) [] -;; - - -let rec list_find_first (l: 'a list) (f: 'a -> 'b option) : 'b option = - match l with - [] -> None - | h :: t -> begin - match f h with - None -> list_find_first t f - | r -> r - end - -(** Generates the range of integers starting with a and ending with b *) -let int_range_list (a: int) (b: int) = - list_init (b - a + 1) (fun i -> a + i) - - -(** Some handling of registers *) -type 'a growArrayFill = - Elem of 'a - | Susp of (int -> 'a) - -type 'a growArray = { - gaFill: 'a growArrayFill; - (** Stuff to use to fill in the array as it grows *) - - mutable gaMaxInitIndex: int; - (** Maximum index that was written to. -1 if no writes have - * been made. *) - - mutable gaData: 'a array; - } - -let growTheArray (ga: 'a growArray) (len: int) - (toidx: int) (why: string) : unit = - if toidx >= len then begin - (* Grow the array by 50% *) - let newlen = toidx + 1 + len / 2 in -(* - ignore (E.log "growing an array to idx=%d (%s)\n" toidx why); -*) - let data' = begin match ga.gaFill with - Elem x -> - - let data'' = Array.create newlen x in - Array.blit ga.gaData 0 data'' 0 len; - data'' - | Susp f -> Array.init newlen - (fun i -> if i < len then ga.gaData.(i) else f i) - end - in - ga.gaData <- data' - end - -let getReg (ga: 'a growArray) (r: int) : 'a = - let len = Array.length ga.gaData in - if r >= len then - growTheArray ga len r "get"; - - ga.gaData.(r) - -let setReg (ga: 'a growArray) (r: int) (what: 'a) : unit = - let len = Array.length ga.gaData in - if r >= len then - growTheArray ga len r "set"; - if r > ga.gaMaxInitIndex then ga.gaMaxInitIndex <- r; - ga.gaData.(r) <- what - -let newGrowArray (initsz: int) (fill: 'a growArrayFill) : 'a growArray = - { gaFill = fill; - gaMaxInitIndex = -1; - gaData = begin match fill with - Elem x -> Array.create initsz x - | Susp f -> Array.init initsz f - end; } - -let copyGrowArray (ga: 'a growArray) : 'a growArray = - { ga with gaData = Array.copy ga.gaData } - -let deepCopyGrowArray (ga: 'a growArray) (copy: 'a -> 'a): 'a growArray = - { ga with gaData = Array.map copy ga.gaData } - - - -(** Iterate over the initialized elements of the array *) -let growArray_iteri (f: int -> 'a -> unit) (ga: 'a growArray) = - for i = 0 to ga.gaMaxInitIndex do - f i ga.gaData.(i) - done - - -(** Fold left over the initialized elements of the array *) -let growArray_foldl (f: 'acc -> 'a -> 'acc) - (acc: 'acc) (ga: 'a growArray) : 'acc = - let rec loop (acc: 'acc) (idx: int) : 'acc = - if idx > ga.gaMaxInitIndex then - acc - else - loop (f acc ga.gaData.(idx)) (idx + 1) - in - loop acc 0 - - - - -let hasPrefix (prefix: string) (what: string) : bool = - let pl = String.length prefix in - try String.sub what 0 pl = prefix - with Invalid_argument _ -> false - - - -let restoreRef ?(deepCopy=(fun x -> x)) (r: 'a ref) : (unit -> unit) = - let old = deepCopy !r in - (fun () -> r := old) - -let restoreHash ?deepCopy (h: ('a, 'b) H.t) : (unit -> unit) = - let old = - match deepCopy with - None -> H.copy h - | Some f -> - let old = H.create (H.length h) in - H.iter (fun k d -> H.add old k (f d)) h; - old - in - (fun () -> hash_copy_into old h) - -let restoreIntHash ?deepCopy (h: 'a IH.t) : (unit -> unit) = - let old = - match deepCopy with - None -> IH.copy h - | Some f -> - let old = IH.create 13 in - IH.iter (fun k d -> IH.add old k (f d)) h; - old - in - (fun () -> - IH.clear old; - IH.iter (fun i k -> IH.add old i k) h) - -let restoreArray ?deepCopy (a: 'a array) : (unit -> unit) = - let old = Array.copy a in - (match deepCopy with - None -> () - | Some f -> Array.iteri (fun i v -> old.(i) <- f v) old); - (fun () -> Array.blit old 0 a 0 (Array.length a)) - -let runThunks (l: (unit -> unit) list) : (unit -> unit) = - fun () -> List.iter (fun f -> f ()) l - - - -(* Memoize *) -let memoize (h: ('a, 'b) Hashtbl.t) - (arg: 'a) - (f: 'a -> 'b) : 'b = - try - Hashtbl.find h arg - with Not_found -> begin - let res = f arg in - Hashtbl.add h arg res; - res - end - -(* Just another name for memoize *) -let findOrAdd h arg f = memoize h arg f - -(* A tryFinally function *) -let tryFinally - (main: 'a -> 'b) (* The function to run *) - (final: 'b option -> unit) (* Something to run at the end *) - (arg: 'a) : 'b = - try - let res: 'b = main arg in - final (Some res); - res - with e -> begin - final None; - raise e - end - - - - -let valOf : 'a option -> 'a = function - None -> raise (Failure "Util.valOf") - | Some x -> x - -(** - * An accumulating for loop. - * - * Initialize the accumulator with init. The current index and accumulator - * from the previous iteration is passed to f. - *) -let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) = - let rec forloop i acc = - if i > hi then acc - else forloop (i+1) (f i acc) - in - forloop lo init - -(************************************************************************) - -module type STACK = sig - type 'a t - (** The type of stacks containing elements of type ['a]. *) - - exception Empty - (** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *) - - val create : unit -> 'a t - (** Return a new stack, initially empty. *) - - val push : 'a -> 'a t -> unit - (** [push x s] adds the element [x] at the top of stack [s]. *) - - val pop : 'a t -> 'a - (** [pop s] removes and returns the topmost element in stack [s], - or raises [Empty] if the stack is empty. *) - - val top : 'a t -> 'a - (** [top s] returns the topmost element in stack [s], - or raises [Empty] if the stack is empty. *) - - val clear : 'a t -> unit - (** Discard all elements from a stack. *) - - val copy : 'a t -> 'a t - (** Return a copy of the given stack. *) - - val is_empty : 'a t -> bool - (** Return [true] if the given stack is empty, [false] otherwise. *) - - val length : 'a t -> int - (** Return the number of elements in a stack. *) - - val iter : ('a -> unit) -> 'a t -> unit - (** [iter f s] applies [f] in turn to all elements of [s], - from the element at the top of the stack to the element at the - bottom of the stack. The stack itself is unchanged. *) -end - -module Stack = struct - - type 'a t = { mutable length : int; - stack : 'a Stack.t; } - - exception Empty - - let create () = { length = 0; - stack = Stack.create(); } - - let push x s = - s.length <- s.length + 1; - Stack.push x s.stack - - let pop s = - s.length <- s.length - 1; - Stack.pop s.stack - - let top s = - Stack.top s.stack - - let clear s = - s.length <- 0; - Stack.clear s.stack - - let copy s = { length = s.length; - stack = Stack.copy s.stack; } - - let is_empty s = - Stack.is_empty s.stack - - let length s = s.length - - let iter f s = - Stack.iter f s.stack - -end - -(************************************************************************) - -let absoluteFilename (fname: string) = - if Filename.is_relative fname then - Filename.concat (Sys.getcwd ()) fname - else - fname - - -(* mapNoCopy is like map but avoid copying the list if the function does not - * change the elements. *) -let rec mapNoCopy (f: 'a -> 'a) = function - [] -> [] - | (i :: resti) as li -> - let i' = f i in - let resti' = mapNoCopy f resti in - if i' != i || resti' != resti then i' :: resti' else li - -let rec mapNoCopyList (f: 'a -> 'a list) = function - [] -> [] - | (i :: resti) as li -> - let il' = f i in - let resti' = mapNoCopyList f resti in - match il' with - [i'] when i' == i && resti' == resti -> li - | _ -> il' @ resti' - - -(* Use a filter function that does not rewrite the list unless necessary *) -let rec filterNoCopy (f: 'a -> bool) (l: 'a list) : 'a list = - match l with - [] -> [] - | h :: rest when not (f h) -> filterNoCopy f rest - | h :: rest -> - let rest' = filterNoCopy f rest in - if rest == rest' then l else h :: rest' - -(** Join a list of strings *) -let rec joinStrings (sep: string) (sl: string list) = - match sl with - [] -> "" - | [s1] -> s1 - | s1 :: ((_ :: _) as rest) -> s1 ^ sep ^ joinStrings sep rest - - -(************************************************************************ - - Configuration - - ************************************************************************) -(** The configuration data can be of several types **) -type configData = - ConfInt of int - | ConfBool of bool - | ConfFloat of float - | ConfString of string - | ConfList of configData list - - -(* Store here window configuration file *) -let configurationData: (string, configData) H.t = H.create 13 - -let clearConfiguration () = H.clear configurationData - -let setConfiguration (key: string) (c: configData) = - H.replace configurationData key c - -let findConfiguration (key: string) : configData = - H.find configurationData key - -let findConfigurationInt (key: string) : int = - match findConfiguration key with - ConfInt i -> i - | _ -> - ignore (E.warn "Configuration %s is not an integer" key); - raise Not_found - -let useConfigurationInt (key: string) (f: int -> unit) = - try f (findConfigurationInt key) - with Not_found -> () - -let findConfigurationString (key: string) : string = - match findConfiguration key with - ConfString s -> s - | _ -> - ignore (E.warn "Configuration %s is not a string" key); - raise Not_found - -let useConfigurationString (key: string) (f: string -> unit) = - try f (findConfigurationString key) - with Not_found -> () - - -let findConfigurationBool (key: string) : bool = - match findConfiguration key with - ConfBool b -> b - | _ -> - ignore (E.warn "Configuration %s is not a boolean" key); - raise Not_found - -let useConfigurationBool (key: string) (f: bool -> unit) = - try f (findConfigurationBool key) - with Not_found -> () - -let findConfigurationList (key: string) : configData list = - match findConfiguration key with - ConfList l -> l - | _ -> - ignore (E.warn "Configuration %s is not a list" key); - raise Not_found - -let useConfigurationList (key: string) (f: configData list -> unit) = - try f (findConfigurationList key) - with Not_found -> () - - -let saveConfiguration (fname: string) = - (** Convert configuration data to a string, for saving externally *) - let configToString (c: configData) : string = - let buff = Buffer.create 80 in - let rec loop (c: configData) : unit = - match c with - ConfInt i -> - Buffer.add_char buff 'i'; - Buffer.add_string buff (string_of_int i); - Buffer.add_char buff ';' - - | ConfBool b -> - Buffer.add_char buff 'b'; - Buffer.add_string buff (string_of_bool b); - Buffer.add_char buff ';' - - | ConfFloat f -> - Buffer.add_char buff 'f'; - Buffer.add_string buff (string_of_float f); - Buffer.add_char buff ';' - - | ConfString s -> - if String.contains s '"' then - E.s (E.unimp "Guilib: configuration string contains quotes"); - Buffer.add_char buff '"'; - Buffer.add_string buff s; - Buffer.add_char buff '"'; (* '"' *) - - | ConfList l -> - Buffer.add_char buff '['; - List.iter loop l; - Buffer.add_char buff ']' - in - loop c; - Buffer.contents buff - in - try - let oc = open_out fname in - ignore (E.log "Saving configuration to %s\n" (absoluteFilename fname)); - H.iter (fun k c -> - output_string oc (k ^ "\n"); - output_string oc ((configToString c) ^ "\n")) - configurationData; - close_out oc - with _ -> - ignore (E.warn "Cannot open configuration file %s\n" fname) - - -(** Make some regular expressions early *) -let intRegexp = Str.regexp "i\\([0-9]+\\);" -let floatRegexp = Str.regexp "f\\([0-9]+\\.[0-9]+\\);" -let boolRegexp = Str.regexp "b\\(\\(true\\)\\|\\(false\\)\\);" -let stringRegexp = Str.regexp "\"\\([^\"]*\\)\"" - -let loadConfiguration (fname: string) : unit = - H.clear configurationData; - - let stringToConfig (s: string) : configData = - let idx = ref 0 in (** the current index *) - let l = String.length s in - - let rec getOne () : configData = - if !idx >= l then raise Not_found; - - if Str.string_match intRegexp s !idx then begin - idx := Str.match_end (); - ConfInt (int_of_string (Str.matched_group 1 s)) - end else if Str.string_match floatRegexp s !idx then begin - idx := Str.match_end (); - ConfFloat (float_of_string (Str.matched_group 1 s)) - end else if Str.string_match boolRegexp s !idx then begin - idx := Str.match_end (); - ConfBool (bool_of_string (Str.matched_group 1 s)) - end else if Str.string_match stringRegexp s !idx then begin - idx := Str.match_end (); - ConfString (Str.matched_group 1 s) - end else if String.get s !idx = '[' then begin - (* We are starting a list *) - incr idx; - let rec loop (acc: configData list) : configData list = - if !idx >= l then begin - ignore (E.warn "Non-terminated list in configuration %s" s); - raise Not_found - end; - if String.get s !idx = ']' then begin - incr idx; - List.rev acc - end else - loop (getOne () :: acc) - in - ConfList (loop []) - end else begin - ignore (E.warn "Bad configuration element in a list: %s\n" - (String.sub s !idx (l - !idx))); - raise Not_found - end - in - getOne () - in - (try - let ic = open_in fname in - ignore (E.log "Loading configuration from %s\n" (absoluteFilename fname)); - (try - while true do - let k = input_line ic in - let s = input_line ic in - try - let c = stringToConfig s in - setConfiguration k c - with Not_found -> () - done - with End_of_file -> ()); - close_in ic; - with _ -> () (* no file, ignore *)); - - () - - - -(*********************************************************************) -type symbol = int - -(**{ Registering symbol names} *) -let registeredSymbolNames: (string, symbol) H.t = H.create 113 -let symbolNames: string IH.t = IH.create 113 -let nextSymbolId = ref 0 - -(* When we register symbol ranges, we store a naming function for use later - * when we print the symbol *) -let symbolRangeNaming: (int * int * (int -> string)) list ref = ref [] - -(* Reset the symbols. We want to allow the registration of symbols at the - * top-level. This means that we cannot simply clear the hash tables. The - * first time we call "reset" we actually remember the state. *) -let resetThunk: (unit -> unit) option ref = ref None - -let snapshotSymbols () : unit -> unit = - runThunks [ restoreIntHash symbolNames; - restoreRef nextSymbolId; - restoreHash registeredSymbolNames; - restoreRef symbolRangeNaming ] - -let resetSymbols () = - match !resetThunk with - None -> resetThunk := Some (snapshotSymbols ()) - | Some t -> t () - - -let dumpSymbols () = - ignore (E.log "Current symbols\n"); - IH.iter (fun i k -> ignore (E.log " %s -> %d\n" k i)) symbolNames; - () - -let newSymbol (n: string) : symbol = - assert(not (H.mem registeredSymbolNames n)); - let id = !nextSymbolId in - incr nextSymbolId; - H.add registeredSymbolNames n id; - IH.add symbolNames id n; - id - -let registerSymbolName (n: string) : symbol = - try H.find registeredSymbolNames n - with Not_found -> begin - newSymbol n - end - -(** Register a range of symbols. The mkname function will be invoked for - * indices starting at 0 *) -let registerSymbolRange (count: int) (mkname: int -> string) : symbol = - if count < 0 then E.s (E.bug "registerSymbolRange: invalid counter"); - let first = !nextSymbolId in - nextSymbolId := !nextSymbolId + count; - symbolRangeNaming := - (first, !nextSymbolId - 1, mkname) :: !symbolRangeNaming; - first - -let symbolName (id: symbol) : string = - try IH.find symbolNames id - with Not_found -> - (* Perhaps it is one of the lazily named symbols *) - try - let (fst, _, mkname) = - List.find - (fun (fst,lst,_) -> fst <= id && id <= lst) - !symbolRangeNaming in - let n = mkname (id - fst) in - IH.add symbolNames id n; - n - with Not_found -> - ignore (E.warn "Cannot find the name of symbol %d" id); - "symbol" ^ string_of_int id - -(************************************************************************) - -(** {1 Int32 Operators} *) - -module Int32Op = struct - exception IntegerTooLarge - let to_int (i: int32) = - let i' = Int32.to_int i in (* Silently drop the 32nd bit *) - if i = Int32.of_int i' then i' - else raise IntegerTooLarge - - let (<%) = (fun x y -> (Int32.compare x y) < 0) - let (<=%) = (fun x y -> (Int32.compare x y) <= 0) - let (>%) = (fun x y -> (Int32.compare x y) > 0) - let (>=%) = (fun x y -> (Int32.compare x y) >= 0) - let (<>%) = (fun x y -> (Int32.compare x y) <> 0) - - let (+%) = Int32.add - let (-%) = Int32.sub - let ( *% ) = Int32.mul - let (/%) = Int32.div - let (~-%) = Int32.neg - - (* We cannot use the <<% because it trips camlp4 *) - let sll = fun i j -> Int32.shift_left i (to_int j) - let (>>%) = fun i j -> Int32.shift_right i (to_int j) - let (>>>%) = fun i j -> Int32.shift_right_logical i (to_int j) -end - - -(*********************************************************************) - -let equals x1 x2 : bool = - (compare x1 x2) = 0 diff --git a/cil/ocamlutil/util.mli b/cil/ocamlutil/util.mli deleted file mode 100644 index d701c65..0000000 --- a/cil/ocamlutil/util.mli +++ /dev/null @@ -1,311 +0,0 @@ -(** A bunch of generally useful functions *) - -exception GotSignal of int - -val withTimeout : float -> (* Seconds for timeout *) - (int -> 'b) -> (* What to do if we have a timeout. The - * argument passed is the signal number - * received. *) - ('a -> 'b) -> (* The function to run *) - 'a -> (* And its argument *) - 'b - -val docHash : ?sep:Pretty.doc -> ('a -> 'b -> Pretty.doc) -> unit -> - (('a, 'b) Hashtbl.t) -> Pretty.doc - - -val hash_to_list: ('a, 'b) Hashtbl.t -> ('a * 'b) list - -val keys: ('a, 'b) Hashtbl.t -> 'a list - - -(** Copy a hash table into another *) -val hash_copy_into: ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -> unit - -(** First, a few utility functions I wish were in the standard prelude *) - -val anticompare: 'a -> 'a -> int - -val list_drop : int -> 'a list -> 'a list -val list_droptail : int -> 'a list -> 'a list -val list_span: ('a -> bool) -> ('a list) -> 'a list * 'a list -val list_insert_by: ('a -> 'a -> int) -> 'a -> 'a list -> 'a list -val list_head_default: 'a -> 'a list -> 'a -val list_iter3 : ('a -> 'b -> 'c -> unit) -> - 'a list -> 'b list -> 'c list -> unit -val get_some_option_list : 'a option list -> 'a list -val list_append: ('a list) -> ('a list) -> ('a list) (* tail-recursive append*) - -(** Iterate over a list passing the index as you go *) -val list_iteri: (int -> 'a -> unit) -> 'a list -> unit -val list_mapi: (int -> 'a -> 'b) -> 'a list -> 'b list - -(** Like fold_left but pass the index into the list as well *) -val list_fold_lefti: ('acc -> int -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc - -(** Generates the range of integers starting with a and ending with b *) -val int_range_list : int -> int -> int list - -(* Create a list of length l *) -val list_init : int -> (int -> 'a) -> 'a list - -(** Find the first element in a list that returns Some *) -val list_find_first: 'a list -> ('a -> 'b option) -> 'b option - -(** mapNoCopy is like map but avoid copying the list if the function does not - * change the elements *) - -val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list - -val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list - -val filterNoCopy: ('a -> bool) -> 'a list -> 'a list - - -(** Join a list of strings *) -val joinStrings: string -> string list -> string - - -(**** Now in growArray.mli - -(** Growable arrays *) -type 'a growArrayFill = - Elem of 'a - | Susp of (int -> 'a) - -type 'a growArray = { - gaFill: 'a growArrayFill; - (** Stuff to use to fill in the array as it grows *) - - mutable gaMaxInitIndex: int; - (** Maximum index that was written to. -1 if no writes have - * been made. *) - - mutable gaData: 'a array; - } - -val newGrowArray: int -> 'a growArrayFill -> 'a growArray -(** [newGrowArray initsz fillhow] *) - -val getReg: 'a growArray -> int -> 'a -val setReg: 'a growArray -> int -> 'a -> unit -val copyGrowArray: 'a growArray -> 'a growArray -val deepCopyGrowArray: 'a growArray -> ('a -> 'a) -> 'a growArray - - -val growArray_iteri: (int -> 'a -> unit) -> 'a growArray -> unit -(** Iterate over the initialized elements of the array *) - -val growArray_foldl: ('acc -> 'a -> 'acc) -> 'acc ->'a growArray -> 'acc -(** Fold left over the initialized elements of the array *) - -****) - -(** hasPrefix prefix str returns true with str starts with prefix *) -val hasPrefix: string -> string -> bool - - -(** Given a ref cell, produce a thunk that later restores it to its current value *) -val restoreRef: ?deepCopy:('a -> 'a) -> 'a ref -> unit -> unit - -(** Given a hash table, produce a thunk that later restores it to its current value *) -val restoreHash: ?deepCopy:('b -> 'b) -> ('a, 'b) Hashtbl.t -> unit -> unit - -(** Given an integer hash table, produce a thunk that later restores it to - * its current value *) -val restoreIntHash: ?deepCopy:('b -> 'b) -> 'b Inthash.t -> unit -> unit - -(** Given an array, produce a thunk that later restores it to its current value *) -val restoreArray: ?deepCopy:('a -> 'a) -> 'a array -> unit -> unit - - -(** Given a list of thunks, produce a thunk that runs them all *) -val runThunks: (unit -> unit) list -> unit -> unit - - -val memoize: ('a, 'b) Hashtbl.t -> - 'a -> - ('a -> 'b) -> 'b - -(** Just another name for memoize *) -val findOrAdd: ('a, 'b) Hashtbl.t -> - 'a -> - ('a -> 'b) -> 'b - -val tryFinally: - ('a -> 'b) -> (* The function to run *) - ('b option -> unit) -> (* Something to run at the end. The None case is - * used when an exception is thrown *) - 'a -> 'b - - - - -(** Get the value of an option. Raises Failure if None *) -val valOf : 'a option -> 'a - -(** - * An accumulating for loop. - * - * Initialize the accumulator with init. The current index and accumulator - * from the previous iteration is passed to f. - *) -val fold_for : init:'a -> lo:int -> hi:int -> (int -> 'a -> 'a) -> 'a - -(************************************************************************) - -module type STACK = sig - type 'a t - (** The type of stacks containing elements of type ['a]. *) - - exception Empty - (** Raised when {!Util.Stack.pop} or {!Util.Stack.top} is applied to an - * empty stack. *) - - val create : unit -> 'a t - - - val push : 'a -> 'a t -> unit - (** [push x s] adds the element [x] at the top of stack [s]. *) - - val pop : 'a t -> 'a - (** [pop s] removes and returns the topmost element in stack [s], - or raises [Empty] if the stack is empty. *) - - val top : 'a t -> 'a - (** [top s] returns the topmost element in stack [s], - or raises [Empty] if the stack is empty. *) - - val clear : 'a t -> unit - (** Discard all elements from a stack. *) - - val copy : 'a t -> 'a t - (** Return a copy of the given stack. *) - - val is_empty : 'a t -> bool - (** Return [true] if the given stack is empty, [false] otherwise. *) - - val length : 'a t -> int - (** Return the number of elements in a stack. *) - - val iter : ('a -> unit) -> 'a t -> unit - (** [iter f s] applies [f] in turn to all elements of [s], - from the element at the top of the stack to the element at the - bottom of the stack. The stack itself is unchanged. *) -end - -module Stack : STACK - -(************************************************************************ - Configuration -************************************************************************) -(** The configuration data can be of several types **) -type configData = - ConfInt of int - | ConfBool of bool - | ConfFloat of float - | ConfString of string - | ConfList of configData list - - -(** Load the configuration from a file *) -val loadConfiguration: string -> unit - -(** Save the configuration in a file. Overwrites the previous values *) -val saveConfiguration: string -> unit - - -(** Clear all configuration data *) -val clearConfiguration: unit -> unit - -(** Set a configuration element, with a key. Overwrites the previous values *) -val setConfiguration: string -> configData -> unit - -(** Find a configuration elements, given a key. Raises Not_found if it canont - * find it *) -val findConfiguration: string -> configData - -(** Like findConfiguration but extracts the integer *) -val findConfigurationInt: string -> int - -(** Looks for an integer configuration element, and if it is found, it uses - * the given function. Otherwise, does nothing *) -val useConfigurationInt: string -> (int -> unit) -> unit - - -val findConfigurationBool: string -> bool -val useConfigurationBool: string -> (bool -> unit) -> unit - -val findConfigurationString: string -> string -val useConfigurationString: string -> (string -> unit) -> unit - -val findConfigurationList: string -> configData list -val useConfigurationList: string -> (configData list -> unit) -> unit - - -(************************************************************************) - -(** Symbols are integers that are uniquely associated with names *) -type symbol = int - -(** Get the name of a symbol *) -val symbolName: symbol -> string - -(** Register a symbol name and get the symbol for it *) -val registerSymbolName: string -> symbol - -(** Register a number of consecutive symbol ids. The naming function will be - * invoked with indices from 0 to the counter - 1. Returns the id of the - * first symbol created. The naming function is invoked lazily, only when the - * name of the symbol is required. *) -val registerSymbolRange: int -> (int -> string) -> symbol - - -(** Make a fresh symbol. Give the name also, which ought to be distinct from - * existing symbols. This is different from registerSymbolName in that it - * always creates a new symbol. *) -val newSymbol: string -> symbol - -(** Reset the state of the symbols to the program startup state *) -val resetSymbols: unit -> unit - -(** Take a snapshot of the symbol state. Returns a thunk that restores the - * state. *) -val snapshotSymbols: unit -> unit -> unit - - -(** Dump the list of registered symbols *) -val dumpSymbols: unit -> unit - -(************************************************************************) - -(** {1 Int32 Operators} *) - -module Int32Op : sig - val (<%) : int32 -> int32 -> bool - val (<=%) : int32 -> int32 -> bool - val (>%) : int32 -> int32 -> bool - val (>=%) : int32 -> int32 -> bool - val (<>%) : int32 -> int32 -> bool - - val (+%) : int32 -> int32 -> int32 - val (-%) : int32 -> int32 -> int32 - val ( *% ) : int32 -> int32 -> int32 - val (/%) : int32 -> int32 -> int32 - val (~-%) : int32 -> int32 - - val sll : int32 -> int32 -> int32 - val (>>%) : int32 -> int32 -> int32 - val (>>>%) : int32 -> int32 -> int32 - - exception IntegerTooLarge - val to_int : int32 -> int -end - -(************************************************************************) - -(** This has the semantics of (=) on OCaml 3.07 and earlier. It can - handle cyclic values as long as a structure in the cycle has a unique - name or id in some field that occurs before any fields that have cyclic - pointers. *) -val equals: 'a -> 'a -> bool diff --git a/cil/src/check.ml b/cil/src/check.ml deleted file mode 100644 index 4dc8850..0000000 --- a/cil/src/check.ml +++ /dev/null @@ -1,1017 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* A consistency checker for CIL *) -open Cil -module E = Errormsg -module H = Hashtbl -open Pretty - - -(* A few parameters to customize the checking *) -type checkFlags = - NoCheckGlobalIds (* Do not check that the global ids have the proper - * hash value *) - -let checkGlobalIds = ref true - - (* Attributes must be sorted *) -type ctxAttr = - CALocal (* Attribute of a local variable *) - | CAGlobal (* Attribute of a global variable *) - | CAType (* Attribute of a type *) - -let valid = ref true - -let warn fmt = - valid := false; - Cil.warn fmt - -let warnContext fmt = - valid := false; - Cil.warnContext fmt - -let checkAttributes (attrs: attribute list) : unit = - let rec loop lastname = function - [] -> () - | Attr(an, _) :: resta -> - if an < lastname then - ignore (warn "Attributes not sorted"); - loop an resta - in - loop "" attrs - - - (* Keep track of defined types *) -let typeDefs : (string, typ) H.t = H.create 117 - - - (* Keep track of all variables names, enum tags and type names *) -let varNamesEnv : (string, unit) H.t = H.create 117 - - (* We also keep a map of variables indexed by id, to ensure that only one - * varinfo has a given id *) -let varIdsEnv: (int, varinfo) H.t = H.create 117 - - (* And keep track of all varinfo's to check the uniqueness of the - * identifiers *) -let allVarIds: (int, varinfo) H.t = H.create 117 - - (* Also keep a list of environments. We place an empty string in the list to - * mark the start of a local environment (i.e. a function) *) -let varNamesList : (string * int) list ref = ref [] -let defineName s = - if s = "" then - E.s (bug "Empty name\n"); - if H.mem varNamesEnv s then - ignore (warn "Multiple definitions for %s\n" s); - H.add varNamesEnv s () - -let defineVariable vi = - defineName vi.vname; - varNamesList := (vi.vname, vi.vid) :: !varNamesList; - (* Check the id *) - if H.mem allVarIds vi.vid then - ignore (warn "Id %d is already defined (%s)\n" vi.vid vi.vname); - H.add allVarIds vi.vid vi; - (* And register it in the current scope also *) - H.add varIdsEnv vi.vid vi - -(* Check that a varinfo has already been registered *) -let checkVariable vi = - try - (* Check in the current scope only *) - if vi != H.find varIdsEnv vi.vid then - ignore (warnContext "varinfos for %s not shared\n" vi.vname); - with Not_found -> - ignore (warn "Unknown id (%d) for %s\n" vi.vid vi.vname) - - -let startEnv () = - varNamesList := ("", -1) :: !varNamesList - -let endEnv () = - let rec loop = function - [] -> E.s (bug "Cannot find start of env") - | ("", _) :: rest -> varNamesList := rest - | (s, id) :: rest -> begin - H.remove varNamesEnv s; - H.remove varIdsEnv id; - loop rest - end - in - loop !varNamesList - - - -(* The current function being checked *) -let currentReturnType : typ ref = ref voidType - -(* A map of labels in the current function *) -let labels: (string, unit) H.t = H.create 17 - -(* A list of statements seen in the current function *) -let statements: stmt list ref = ref [] - -(* A list of the targets of Gotos *) -let gotoTargets: (string * stmt) list ref = ref [] - -(*** TYPES ***) -(* Cetain types can only occur in some contexts, so keep a list of context *) -type ctxType = - CTStruct (* In a composite type *) - | CTUnion - | CTFArg (* In a function argument type *) - | CTFRes (* In a function result type *) - | CTArray (* In an array type *) - | CTPtr (* In a pointer type *) - | CTExp (* In an expression, as the type of - * the result of binary operators, or - * in a cast *) - | CTSizeof (* In a sizeof *) - | CTDecl (* In a typedef, or a declaration *) - -let d_context () = function - CTStruct -> text "CTStruct" - | CTUnion -> text "CTUnion" - | CTFArg -> text "CTFArg" - | CTFRes -> text "CTFRes" - | CTArray -> text "CTArray" - | CTPtr -> text "CTPtr" - | CTExp -> text "CTExp" - | CTSizeof -> text "CTSizeof" - | CTDecl -> text "CTDecl" - - -(* Keep track of all tags that we use. For each tag remember also the info - * structure and a flag whether it was actually defined or just used. A - * forward declaration acts as a definition. *) -type defuse = - Defined (* We actually have seen a definition of this tag *) - | Forward (* We have seen a forward declaration for it. This is done using - * a GType with an empty type name *) - | Used (* Only uses *) -let compUsed : (int, compinfo * defuse ref) H.t = H.create 117 -let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117 -let typUsed : (string, typeinfo * defuse ref) H.t = H.create 117 - -(* For composite types we also check that the names are unique *) -let compNames : (string, unit) H.t = H.create 17 - - - (* Check a type *) -let rec checkType (t: typ) (ctx: ctxType) = - (* Check that it appears in the right context *) - let rec checkContext = function - TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl - | TNamed (ti, a) -> checkContext ti.ttype - | TArray _ -> - (ctx = CTStruct || ctx = CTUnion - || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr) - | TComp _ -> ctx <> CTExp - | _ -> true - in - if not (checkContext t) then - ignore (warn "Type (%a) used in wrong context. Expected context: %a" - d_plaintype t d_context ctx); - match t with - (TVoid a | TBuiltin_va_list a) -> checkAttributes a - | TInt (ik, a) -> checkAttributes a - | TFloat (_, a) -> checkAttributes a - | TPtr (t, a) -> checkAttributes a; checkType t CTPtr - - | TNamed (ti, a) -> - checkAttributes a; - if ti.tname = "" then - ignore (warnContext "Using a typeinfo for an empty-named type\n"); - checkTypeInfo Used ti - - | TComp (comp, a) -> - checkAttributes a; - (* Mark it as a forward. We'll check it later. If we try to check it - * now we might encounter undefined types *) - checkCompInfo Used comp - - - | TEnum (enum, a) -> begin - checkAttributes a; - checkEnumInfo Used enum - end - - | TArray(bt, len, a) -> - checkAttributes a; - checkType bt CTArray; - (match len with - None -> () - | Some l -> begin - let t = checkExp true l in - match t with - TInt((IInt|IUInt), _) -> () - | _ -> E.s (bug "Type of array length is not integer") - end) - - | TFun (rt, targs, isva, a) -> - checkAttributes a; - checkType rt CTFRes; - List.iter - (fun (an, at, aa) -> - checkType at CTFArg; - checkAttributes aa) (argsToList targs) - -(* Check that a type is a promoted integral type *) -and checkIntegralType (t: typ) = - checkType t CTExp; - match unrollType t with - TInt _ -> () - | _ -> ignore (warn "Non-integral type") - -(* Check that a type is a promoted arithmetic type *) -and checkArithmeticType (t: typ) = - checkType t CTExp; - match unrollType t with - TInt _ | TFloat _ -> () - | _ -> ignore (warn "Non-arithmetic type") - -(* Check that a type is a promoted boolean type *) -and checkBooleanType (t: typ) = - checkType t CTExp; - match unrollType t with - TInt _ | TFloat _ | TPtr _ -> () - | _ -> ignore (warn "Non-boolean type") - - -(* Check that a type is a pointer type *) -and checkPointerType (t: typ) = - checkType t CTExp; - match unrollType t with - TPtr _ -> () - | _ -> ignore (warn "Non-pointer type") - - -and typeMatch (t1: typ) (t2: typ) = - if typeSig t1 <> typeSig t2 then - match unrollType t1, unrollType t2 with - (* Allow free interchange of TInt and TEnum *) - TInt (IInt, _), TEnum _ -> () - | TEnum _, TInt (IInt, _) -> () - - | _, _ -> ignore (warn "Type mismatch:@! %a@!and %a@!" - d_type t1 d_type t2) - -and checkCompInfo (isadef: defuse) comp = - let fullname = compFullName comp in - try - let oldci, olddef = H.find compUsed comp.ckey in - (* Check that it is the same *) - if oldci != comp then - ignore (warnContext "compinfo for %s not shared\n" fullname); - (match !olddef, isadef with - | Defined, Defined -> - ignore (warnContext "Multiple definition of %s\n" fullname) - | _, Defined -> olddef := Defined - | Defined, _ -> () - | _, Forward -> olddef := Forward - | _, _ -> ()) - with Not_found -> begin (* This is the first time we see it *) - (* Check that the name is not empty *) - if comp.cname = "" then - E.s (bug "Compinfo with empty name"); - (* Check that the name is unique *) - if H.mem compNames fullname then - ignore (warn "Duplicate name %s" fullname); - (* Add it to the map before we go on *) - H.add compUsed comp.ckey (comp, ref isadef); - H.add compNames fullname (); - (* Do not check the compinfo unless this is a definition. Otherwise you - * might run into undefined types. *) - if isadef = Defined then begin - checkAttributes comp.cattr; - let fctx = if comp.cstruct then CTStruct else CTUnion in - let rec checkField f = - if not - (f.fcomp == comp && (* Each field must share the self cell of - * the host *) - f.fname <> "") then - ignore (warn "Self pointer not set in field %s of %s" - f.fname fullname); - checkType f.ftype fctx; - (* Check the bitfields *) - (match unrollType f.ftype, f.fbitfield with - | TInt (ik, a), Some w -> - checkAttributes a; - if w < 0 || w >= bitsSizeOf (TInt(ik, a)) then - ignore (warn "Wrong width (%d) in bitfield" w) - | _, Some w -> - ignore (E.error "Bitfield on a non integer type\n") - | _ -> ()); - checkAttributes f.fattr - in - List.iter checkField comp.cfields - end - end - - -and checkEnumInfo (isadef: defuse) enum = - if enum.ename = "" then - E.s (bug "Enuminfo with empty name"); - try - let oldei, olddef = H.find enumUsed enum.ename in - (* Check that it is the same *) - if oldei != enum then - ignore (warnContext "enuminfo for %s not shared\n" enum.ename); - (match !olddef, isadef with - Defined, Defined -> - ignore (warnContext "Multiple definition of enum %s\n" enum.ename) - | _, Defined -> olddef := Defined - | Defined, _ -> () - | _, Forward -> olddef := Forward - | _, _ -> ()) - with Not_found -> begin (* This is the first time we see it *) - (* Add it to the map before we go on *) - H.add enumUsed enum.ename (enum, ref isadef); - checkAttributes enum.eattr; - List.iter (fun (tn, _, _) -> defineName tn) enum.eitems; - end - -and checkTypeInfo (isadef: defuse) ti = - try - let oldti, olddef = H.find typUsed ti.tname in - (* Check that it is the same *) - if oldti != ti then - ignore (warnContext "typeinfo for %s not shared\n" ti.tname); - (match !olddef, isadef with - Defined, Defined -> - ignore (warnContext "Multiple definition of type %s\n" ti.tname) - | Defined, Used -> () - | Used, Defined -> - ignore (warnContext "Use of type %s before its definition\n" ti.tname) - | _, _ -> - ignore (warnContext "Bug in checkTypeInfo for %s\n" ti.tname)) - with Not_found -> begin (* This is the first time we see it *) - if ti.tname = "" then - ignore (warnContext "typeinfo with empty name"); - checkType ti.ttype CTDecl; - (* Add it to the map before we go on *) - H.add typUsed ti.tname (ti, ref isadef); - end - -(* Check an lvalue. If isconst then the lvalue appears in a context where - * only a compile-time constant can appear. Return the type of the lvalue. - * See the typing rule from cil.mli *) -and checkLval (isconst: bool) (lv: lval) : typ = - match lv with - Var vi, off -> - checkVariable vi; - checkOffset vi.vtype off - - | Mem addr, off -> begin - if isconst then - ignore (warn "Memory operation in constant"); - let ta = checkExp false addr in - match unrollType ta with - TPtr (t, _) -> checkOffset t off - | _ -> E.s (bug "Mem on a non-pointer") - end - -(* Check an offset. The basetype is the type of the object referenced by the - * base. Return the type of the lvalue constructed from a base value of right - * type and the offset. See the typing rules from cil.mli *) -and checkOffset basetyp : offset -> typ = function - NoOffset -> basetyp - | Index (ei, o) -> - checkExpType false ei intType; - begin - match unrollType basetyp with - TArray (t, _, _) -> checkOffset t o - | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t) - end - - | Field (fi, o) -> - (* Now check that the host is shared propertly *) - checkCompInfo Used fi.fcomp; - (* Check that this exact field is part of the host *) - if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then - ignore (warn "Field %s not part of %s" - fi.fname (compFullName fi.fcomp)); - checkOffset fi.ftype o - -and checkExpType (isconst: bool) (e: exp) (t: typ) = - let t' = checkExp isconst e in (* compute the type *) - if isconst then begin (* For initializers allow a string to initialize an - * array of characters *) - if typeSig t' <> typeSig t then - match e, t with - | _ -> typeMatch t' t - end else - typeMatch t' t - -(* Check an expression. isconst specifies if the expression occurs in a - * context where only a compile-time constant can occur. Return the computed - * type of the expression *) -and checkExp (isconst: bool) (e: exp) : typ = - E.withContext - (fun _ -> dprintf "check%s: %a" - (if isconst then "Const" else "Exp") d_exp e) - (fun _ -> - match e with - | Const(CInt64 (_, ik, _)) -> TInt(ik, []) - | Const(CChr _) -> charType - | Const(CStr s) -> charPtrType - | Const(CWStr s) -> TPtr(!wcharType,[]) - | Const(CReal (_, fk, _)) -> TFloat(fk, []) - | Const(CEnum (_, _, ei)) -> TEnum(ei, []) - | Lval(lv) -> - if isconst then - ignore (warn "Lval in constant"); - checkLval isconst lv - - | SizeOf(t) -> begin - (* Sizeof cannot be applied to certain types *) - checkType t CTSizeof; - (match unrollType t with - (TFun _ | TVoid _) -> - ignore (warn "Invalid operand for sizeof") - | _ ->()); - uintType - end - | SizeOfE(e) -> - (* The expression in a sizeof can be anything *) - let te = checkExp false e in - checkExp isconst (SizeOf(te)) - - | SizeOfStr s -> uintType - - | AlignOf(t) -> begin - (* Sizeof cannot be applied to certain types *) - checkType t CTSizeof; - (match unrollType t with - (TFun _ | TVoid _) -> - ignore (warn "Invalid operand for sizeof") - | _ ->()); - uintType - end - | AlignOfE(e) -> - (* The expression in an AlignOfE can be anything *) - let te = checkExp false e in - checkExp isconst (AlignOf(te)) - - | UnOp (Neg, e, tres) -> - checkArithmeticType tres; checkExpType isconst e tres; tres - - | UnOp (BNot, e, tres) -> - checkIntegralType tres; checkExpType isconst e tres; tres - - | UnOp (LNot, e, tres) -> - let te = checkExp isconst e in - checkBooleanType te; - checkIntegralType tres; (* Must check that t is well-formed *) - typeMatch tres intType; - tres - - | BinOp (bop, e1, e2, tres) -> begin - let t1 = checkExp isconst e1 in - let t2 = checkExp isconst e2 in - match bop with - (Mult | Div) -> - typeMatch t1 t2; checkArithmeticType tres; - typeMatch t1 tres; tres - | (Eq|Ne|Lt|Le|Ge|Gt) -> - typeMatch t1 t2; checkArithmeticType t1; - typeMatch tres intType; tres - | Mod|BAnd|BOr|BXor -> - typeMatch t1 t2; checkIntegralType tres; - typeMatch t1 tres; tres - | LAnd | LOr -> - typeMatch t1 t2; checkBooleanType tres; - typeMatch t1 tres; tres - | Shiftlt | Shiftrt -> - typeMatch t1 tres; checkIntegralType t1; - checkIntegralType t2; tres - | (PlusA | MinusA) -> - typeMatch t1 t2; typeMatch t1 tres; - checkArithmeticType tres; tres - | (PlusPI | MinusPI | IndexPI) -> - checkPointerType tres; - typeMatch t1 tres; - checkIntegralType t2; - tres - | MinusPP -> - checkPointerType t1; checkPointerType t2; - typeMatch t1 t2; - typeMatch tres intType; - tres - end - | AddrOf (lv) -> begin - let tlv = checkLval isconst lv in - (* Only certain types can be in AddrOf *) - match unrollType tlv with - | TVoid _ -> - E.s (bug "AddrOf on improper type"); - - | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) -> - TPtr(tlv, []) - - | TEnum _ -> intPtrType - | _ -> E.s (bug "AddrOf on unknown type") - end - - | StartOf lv -> begin - let tlv = checkLval isconst lv in - match unrollType tlv with - TArray (t,_, _) -> TPtr(t, []) - | _ -> E.s (bug "StartOf on a non-array") - end - - | CastE (tres, e) -> begin - let et = checkExp isconst e in - checkType tres CTExp; - (* Not all types can be cast *) - match unrollType et with - TArray _ -> E.s (bug "Cast of an array type") - | TFun _ -> E.s (bug "Cast of a function type") - | TComp _ -> E.s (bug "Cast of a composite type") - | TVoid _ -> E.s (bug "Cast of a void type") - | _ -> tres - end) - () (* The argument of withContext *) - -and checkInit (i: init) : typ = - E.withContext - (fun _ -> dprintf "checkInit: %a" d_init i) - (fun _ -> - match i with - SingleInit e -> checkExp true e -(* - | ArrayInit (bt, len, initl) -> begin - checkType bt CTSizeof; - if List.length initl > len then - ignore (warn "Too many initializers in array"); - List.iter (fun i -> checkInitType i bt) initl; - TArray(bt, Some (integer len), []) - end -*) - | CompoundInit (ct, initl) -> begin - checkType ct CTSizeof; - (match unrollType ct with - TArray(bt, Some (Const(CInt64(len, _, _))), _) -> - let rec loopIndex i = function - [] -> - if i <> len then - ignore (warn "Wrong number of initializers in array") - - | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest -> - if i' <> i then - ignore (warn "Initializer for index %s when %s was expected\n" - (Int64.format "%d" i') (Int64.format "%d" i)); - checkInitType ei bt; - loopIndex (Int64.succ i) rest - | _ :: rest -> - ignore (warn "Malformed initializer for array element") - in - loopIndex Int64.zero initl - | TArray(_, _, _) -> - ignore (warn "Malformed initializer for array") - | TComp (comp, _) -> - if comp.cstruct then - let rec loopFields - (nextflds: fieldinfo list) - (initl: (offset * init) list) : unit = - match nextflds, initl with - [], [] -> () (* We are done *) - | f :: restf, (Field(f', NoOffset), i) :: resti -> - if f.fname <> f'.fname then - ignore (warn "Expected initializer for field %s and found one for %s\n" f.fname f'.fname); - checkInitType i f.ftype; - loopFields restf resti - | [], _ :: _ -> - ignore (warn "Too many initializers for struct") - | _ :: _, [] -> - ignore (warn "Too few initializers for struct") - | _, _ -> - ignore (warn "Malformed initializer for struct") - in - loopFields - (List.filter (fun f -> f.fname <> missingFieldName) - comp.cfields) - initl - - else (* UNION *) - if comp.cfields == [] then begin - if initl != [] then - ignore (warn "Initializer for empty union not empty"); - end else begin - match initl with - [(Field(f, NoOffset), ei)] -> - if f.fcomp != comp then - ignore (bug "Wrong designator for union initializer"); - if !msvcMode && f != List.hd comp.cfields then - ignore (warn "On MSVC you can only initialize the first field of a union"); - checkInitType ei f.ftype - - | _ -> - ignore (warn "Malformed initializer for union") - end - | _ -> - E.s (warn "Type of Compound is not array or struct or union")); - ct - end) - () (* The arguments of withContext *) - - -and checkInitType (i: init) (t: typ) : unit = - let it = checkInit i in - typeMatch it t - -and checkStmt (s: stmt) = - E.withContext - (fun _ -> - (* Print context only for certain small statements *) - match s.skind with - (*Loop _*) While _ | DoWhile _ | For _ | If _ | Switch _ -> nil - | _ -> dprintf "checkStmt: %a" d_stmt s) - (fun _ -> - (* Check the labels *) - let checkLabel = function - Label (ln, l, _) -> - if H.mem labels ln then - ignore (warn "Multiply defined label %s" ln); - H.add labels ln () - | Case (e, _) -> checkExpType true e intType - | _ -> () (* Not yet implemented *) - in - List.iter checkLabel s.labels; - (* See if we have seen this statement before *) - if List.memq s !statements then - ignore (warn "Statement is shared"); - (* Remember that we have seen this one *) - statements := s :: !statements; - match s.skind with - Break _ | Continue _ -> () - | Goto (gref, l) -> - currentLoc := l; - (* Find a label *) - let lab = - match List.filter (function Label _ -> true | _ -> false) - !gref.labels with - Label (lab, _, _) :: _ -> lab - | _ -> - ignore (warn "Goto to block without a label\n"); - "" - in - (* Remember it as a target *) - gotoTargets := (lab, !gref) :: !gotoTargets - - - | Return (re,l) -> begin - currentLoc := l; - match re, !currentReturnType with - None, TVoid _ -> () - | _, TVoid _ -> ignore (warn "Invalid return value") - | None, _ -> ignore (warn "Invalid return value") - | Some re', rt' -> checkExpType false re' rt' - end -(* - | Loop (b, l, _, _) -> checkBlock b -*) - | While (e, b, l) -> - currentLoc := l; - let te = checkExp false e in - checkBooleanType te; - checkBlock b; - | DoWhile (e, b, l) -> - currentLoc := l; - let te = checkExp false e in - checkBooleanType te; - checkBlock b; - | For (bInit, e, bIter, b, l) -> - currentLoc := l; - checkBlock bInit; - let te = checkExp false e in - checkBooleanType te; - checkBlock bIter; - checkBlock b; - | Block b -> checkBlock b - | If (e, bt, bf, l) -> - currentLoc := l; - let te = checkExp false e in - checkBooleanType te; - checkBlock bt; - checkBlock bf - | Switch (e, b, cases, l) -> - currentLoc := l; - checkExpType false e intType; - (* Remember the statements so far *) - let prevStatements = !statements in - checkBlock b; - (* Now make sure that all the cases do occur in that block *) - List.iter - (fun c -> - if not (List.exists (function Case _ -> true | _ -> false) - c.labels) then - ignore (warn "Case in switch statment without a \"case\"\n"); - (* Make sure it is in there *) - let rec findCase = function - | l when l == prevStatements -> (* Not found *) - ignore (warnContext - "Cannot find target of switch statement") - | [] -> E.s (E.bug "Check: findCase") - | c' :: rest when c == c' -> () (* Found *) - | _ :: rest -> findCase rest - in - findCase !statements) - cases; - | TryFinally (b, h, l) -> - currentLoc := l; - checkBlock b; - checkBlock h - - | TryExcept (b, (il, e), h, l) -> - currentLoc := l; - checkBlock b; - List.iter checkInstr il; - checkExpType false e intType; - checkBlock h - - | Instr il -> List.iter checkInstr il) - () (* argument of withContext *) - -and checkBlock (b: block) : unit = - List.iter checkStmt b.bstmts - - -and checkInstr (i: instr) = - match i with - | Set (dest, e, l) -> - currentLoc := l; - let t = checkLval false dest in - (* Not all types can be assigned to *) - (match unrollType t with - TFun _ -> ignore (warn "Assignment to a function type") - | TArray _ -> ignore (warn "Assignment to an array type") - | TVoid _ -> ignore (warn "Assignment to a void type") - | _ -> ()); - checkExpType false e t - - | Call(dest, what, args, l) -> - currentLoc := l; - let (rt, formals, isva) = - match checkExp false what with - TFun(rt, formals, isva, _) -> rt, formals, isva - | _ -> E.s (bug "Call to a non-function") - in - (* Now check the return value*) - (match dest, unrollType rt with - None, TVoid _ -> () - | Some _, TVoid _ -> ignore (warn "void value is assigned") - | None, _ -> () (* "Call of function is not assigned" *) - | Some destlv, rt' -> - let desttyp = checkLval false destlv in - if typeSig desttyp <> typeSig rt then begin - (* Not all types can be assigned to *) - (match unrollType desttyp with - TFun _ -> ignore (warn "Assignment to a function type") - | TArray _ -> ignore (warn "Assignment to an array type") - | TVoid _ -> ignore (warn "Assignment to a void type") - | _ -> ()); - (* Not all types can be cast *) - (match rt' with - TArray _ -> ignore (warn "Cast of an array type") - | TFun _ -> ignore (warn "Cast of a function type") - | TComp _ -> ignore (warn "Cast of a composite type") - | TVoid _ -> ignore (warn "Cast of a void type") - - | _ -> ()) - end); - (* Now check the arguments *) - let rec loopArgs formals args = - match formals, args with - [], _ when (isva || args = []) -> () - | (fn,ft,_) :: formals, a :: args -> - checkExpType false a ft; - loopArgs formals args - | _, _ -> ignore (warn "Not enough arguments") - in - if formals = None then - ignore (warn "Call to function without prototype\n") - else - loopArgs (argsToList formals) args - - | Asm _ -> () (* Not yet implemented *) - -let rec checkGlobal = function - GAsm _ -> () - | GPragma _ -> () - | GText _ -> () - | GType (ti, l) -> - currentLoc := l; - E.withContext (fun _ -> dprintf "GType(%s)" ti.tname) - (fun _ -> - checkTypeInfo Defined ti; - if ti.tname <> "" then defineName ti.tname) - () - - | GCompTag (comp, l) -> - currentLoc := l; - checkCompInfo Defined comp; - - | GCompTagDecl (comp, l) -> - currentLoc := l; - checkCompInfo Forward comp; - - | GEnumTag (enum, l) -> - currentLoc := l; - checkEnumInfo Defined enum - - | GEnumTagDecl (enum, l) -> - currentLoc := l; - checkEnumInfo Forward enum - - | GVarDecl (vi, l) -> - currentLoc := l; - (* We might have seen it already *) - E.withContext (fun _ -> dprintf "GVarDecl(%s)" vi.vname) - (fun _ -> - (* If we have seen this vid already then it must be for the exact - * same varinfo *) - if H.mem varIdsEnv vi.vid then - checkVariable vi - else begin - defineVariable vi; - checkAttributes vi.vattr; - checkType vi.vtype CTDecl; - if not (vi.vglob && - vi.vstorage <> Register) then - E.s (bug "Invalid declaration of %s" vi.vname) - end) - () - - | GVar (vi, init, l) -> - currentLoc := l; - (* Maybe this is the first occurrence *) - E.withContext (fun _ -> dprintf "GVar(%s)" vi.vname) - (fun _ -> - checkGlobal (GVarDecl (vi, l)); - (* Check the initializer *) - begin match init.init with - None -> () - | Some i -> ignore (checkInitType i vi.vtype) - end; - (* Cannot be a function *) - if isFunctionType vi.vtype then - E.s (bug "GVar for a function (%s)\n" vi.vname); - ) - () - - - | GFun (fd, l) -> begin - currentLoc := l; - (* Check if this is the first occurrence *) - let vi = fd.svar in - let fname = vi.vname in - E.withContext (fun _ -> dprintf "GFun(%s)" fname) - (fun _ -> - checkGlobal (GVarDecl (vi, l)); - (* Check that the argument types in the type are identical to the - * formals *) - let rec loopArgs targs formals = - match targs, formals with - [], [] -> () - | (fn, ft, fa) :: targs, fo :: formals -> - if fn <> fo.vname || ft != fo.vtype || fa != fo.vattr then - ignore (warnContext - "Formal %s not shared (type + locals) in %s" - fo.vname fname); - loopArgs targs formals - - | _ -> - E.s (bug "Type has different number of formals for %s" - fname) - in - begin match vi.vtype with - TFun (rt, args, isva, a) -> begin - currentReturnType := rt; - loopArgs (argsToList args) fd.sformals - end - | _ -> E.s (bug "Function %s does not have a function type" - fname) - end; - ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" fname)); - (* Now start a new environment, in a finally clause *) - begin try - startEnv (); - (* Do the locals *) - let doLocal tctx v = - if v.vglob then - ignore (warnContext - "Local %s has the vglob flag set" v.vname); - if v.vstorage <> NoStorage && v.vstorage <> Register then - ignore (warnContext - "Local %s has storage %a\n" v.vname - d_storage v.vstorage); - checkType v.vtype tctx; - checkAttributes v.vattr; - defineVariable v - in - List.iter (doLocal CTFArg) fd.sformals; - List.iter (doLocal CTDecl) fd.slocals; - statements := []; - gotoTargets := []; - checkBlock fd.sbody; - H.clear labels; - (* Now verify that we have scanned all targets *) - List.iter - (fun (lab, t) -> if not (List.memq t !statements) then - ignore (warnContext - "Target of \"goto %s\" statement does not appear in function body" lab)) - !gotoTargets; - statements := []; - gotoTargets := []; - (* Done *) - endEnv () - with e -> - endEnv (); - raise e - end; - ()) - () (* final argument of withContext *) - end - - -let checkFile flags fl = - if !E.verboseFlag then ignore (E.log "Checking file %s\n" fl.fileName); - valid := true; - List.iter - (function - NoCheckGlobalIds -> checkGlobalIds := false) - flags; - iterGlobals fl (fun g -> try checkGlobal g with _ -> ()); - (* Check that for all struct/union tags there is a definition *) - H.iter - (fun k (comp, isadef) -> - if !isadef = Used then - begin - valid := false; - ignore (E.warn "Compinfo %s is referenced but not defined" - (compFullName comp)) - end) - compUsed; - (* Check that for all enum tags there is a definition *) - H.iter - (fun k (enum, isadef) -> - if !isadef = Used then - begin - valid := false; - ignore (E.warn "Enuminfo %s is referenced but not defined" - enum.ename) - end) - enumUsed; - (* Clean the hashes to let the GC do its job *) - H.clear typeDefs; - H.clear varNamesEnv; - H.clear varIdsEnv; - H.clear allVarIds; - H.clear compNames; - H.clear compUsed; - H.clear enumUsed; - H.clear typUsed; - varNamesList := []; - if !E.verboseFlag then - ignore (E.log "Finished checking file %s\n" fl.fileName); - !valid - diff --git a/cil/src/check.mli b/cil/src/check.mli deleted file mode 100644 index fdcb8b8..0000000 --- a/cil/src/check.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - (* Checks the well-formedness of the file. Prints warnings and - * returns false if errors are found *) - -type checkFlags = - NoCheckGlobalIds (* Do not check that the global ids have the proper - * hash value *) - -val checkFile: checkFlags list -> Cil.file -> bool diff --git a/cil/src/cil.ml b/cil/src/cil.ml deleted file mode 100644 index 2c4e12a..0000000 --- a/cil/src/cil.ml +++ /dev/null @@ -1,6427 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -(* MODIF: useLogicalOperators flag set to true by default. *) - -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -open Escape -open Pretty -open Trace (* sm: 'trace' function *) -module E = Errormsg -module H = Hashtbl -module IH = Inthash - -(* - * CIL: An intermediate language for analyzing C progams. - * - * Version Tue Dec 12 15:21:52 PST 2000 - * Scott McPeak, George Necula, Wes Weimer - * - *) - -(* The module Cilversion is generated automatically by Makefile from - * information in configure.in *) -let cilVersion = Cilversion.cilVersion -let cilVersionMajor = Cilversion.cilVersionMajor -let cilVersionMinor = Cilversion.cilVersionMinor -let cilVersionRevision = Cilversion.cilVersionRev - -(* A few globals that control the interpretation of C source *) -let msvcMode = ref false (* Whether the pretty printer should - * print output for the MS VC - * compiler. Default is GCC *) - -let useLogicalOperators = ref (*false*) true - - -module M = Machdep -(* Cil.initCil will set this to the current machine description. - Makefile.cil generates the file obj/@ARCHOS@/machdep.ml, - which contains the descriptions of gcc and msvc. *) -let theMachine : M.mach ref = ref M.gcc - - -let lowerConstants: bool ref = ref true - (** Do lower constants (default true) *) -let insertImplicitCasts: bool ref = ref true - (** Do insert implicit casts (default true) *) - - -let little_endian = ref true -let char_is_unsigned = ref false -let underscore_name = ref false - -type lineDirectiveStyle = - | LineComment - | LinePreprocessorInput - | LinePreprocessorOutput - -let lineDirectiveStyle = ref (Some LinePreprocessorInput) - -let print_CIL_Input = ref false - -let printCilAsIs = ref false - -let lineLength = ref 80 - -(* sm: return the string 's' if we're printing output for gcc, suppres - * it if we're printing for CIL to parse back in. the purpose is to - * hide things from gcc that it complains about, but still be able - * to do lossless transformations when CIL is the consumer *) -let forgcc (s: string) : string = - if (!print_CIL_Input) then "" else s - - -let debugConstFold = false - -(** The Abstract Syntax of CIL *) - - -(** The top-level representation of a CIL source file. Its main contents is - the list of global declarations and definitions. *) -type file = - { mutable fileName: string; (** The complete file name *) - mutable globals: global list; (** List of globals as they will appear - in the printed file *) - mutable globinit: fundec option; - (** An optional global initializer function. This is a function where - * you can put stuff that must be executed before the program is - * started. This function, is conceptually at the end of the file, - * although it is not part of the globals list. Use {!Cil.getGlobInit} - * to create/get one. *) - mutable globinitcalled: bool; - (** Whether the global initialization function is called in main. This - should always be false if there is no global initializer. When - you create a global initialization CIL will try to insert code in - main to call it. *) - } - -and comment = location * string - -(** The main type for representing global declarations and definitions. A list - of these form a CIL file. The order of globals in the file is generally - important. *) -and global = - | GType of typeinfo * location - (** A typedef. All uses of type names (through the [TNamed] constructor) - must be preceeded in the file by a definition of the name. The string - is the defined name and always not-empty. *) - - | GCompTag of compinfo * location - (** Defines a struct/union tag with some fields. There must be one of - these for each struct/union tag that you use (through the [TComp] - constructor) since this is the only context in which the fields are - printed. Consequently nested structure tag definitions must be - broken into individual definitions with the innermost structure - defined first. *) - - | GCompTagDecl of compinfo * location - (** Declares a struct/union tag. Use as a forward declaration. This is - * printed without the fields. *) - - | GEnumTag of enuminfo * location - (** Declares an enumeration tag with some fields. There must be one of - these for each enumeration tag that you use (through the [TEnum] - constructor) since this is the only context in which the items are - printed. *) - - | GEnumTagDecl of enuminfo * location - (** Declares an enumeration tag. Use as a forward declaration. This is - * printed without the items. *) - - | GVarDecl of varinfo * location - (** A variable declaration (not a definition). If the variable has a - function type then this is a prototype. There can be several - declarations and at most one definition for a given variable. If both - forms appear then they must share the same varinfo structure. A - prototype shares the varinfo with the fundec of the definition. Either - has storage Extern or there must be a definition in this file *) - - | GVar of varinfo * initinfo * location - (** A variable definition. Can have an initializer. The initializer is - * updateable so that you can change it without requiring to recreate - * the list of globals. There can be at most one definition for a - * variable in an entire program. Cannot have storage Extern or function - * type. *) - - - | GFun of fundec * location - (** A function definition. *) - - | GAsm of string * location (** Global asm statement. These ones - can contain only a template *) - | GPragma of attribute * location (** Pragmas at top level. Use the same - syntax as attributes *) - | GText of string (** Some text (printed verbatim) at - top level. E.g., this way you can - put comments in the output. *) - - -(** The various types available. Every type is associated with a list of - * attributes, which are always kept in sorted order. Use {!Cil.addAttribute} - * and {!Cil.addAttributes} to construct list of attributes. If you want to - * inspect a type, you should use {!Cil.unrollType} to see through the uses - * of named types. *) -and typ = - TVoid of attributes (** Void type *) - | TInt of ikind * attributes (** An integer type. The kind specifies - the sign and width. *) - | TFloat of fkind * attributes (** A floating-point type. The kind - specifies the precision. *) - - | TPtr of typ * attributes - (** Pointer type. *) - - | TArray of typ * exp option * attributes - (** Array type. It indicates the base type and the array length. *) - - | TFun of typ * (string * typ * attributes) list option * bool * attributes - (** Function type. Indicates the type of the result, the name, type - * and name attributes of the formal arguments ([None] if no - * arguments were specified, as in a function whose definition or - * prototype we have not seen; [Some \[\]] means void). Use - * {!Cil.argsToList} to obtain a list of arguments. The boolean - * indicates if it is a variable-argument function. If this is the - * type of a varinfo for which we have a function declaration then - * the information for the formals must match that in the - * function's sformals. *) - - | TNamed of typeinfo * attributes - (* The use of a named type. All uses of the same type name must - * share the typeinfo. Each such type name must be preceeded - * in the file by a [GType] global. This is printed as just the - * type name. The actual referred type is not printed here and is - * carried only to simplify processing. To see through a sequence - * of named type references, use {!Cil.unrollType}. The attributes - * are in addition to those given when the type name was defined. *) - - | TComp of compinfo * attributes - (** A reference to a struct or a union type. All references to the - same struct or union must share the same compinfo among them and - with a [GCompTag] global that preceeds all uses (except maybe - those that are pointers to the composite type). The attributes - given are those pertaining to this use of the type and are in - addition to the attributes that were given at the definition of - the type and which are stored in the compinfo. *) - - | TEnum of enuminfo * attributes - (** A reference to an enumeration type. All such references must - share the enuminfo among them and with a [GEnumTag] global that - preceeds all uses. The attributes refer to this use of the - enumeration and are in addition to the attributes of the - enumeration itself, which are stored inside the enuminfo *) - - - - | TBuiltin_va_list of attributes - (** This is the same as the gcc's type with the same name *) - -(** Various kinds of integers *) -and ikind = - IChar (** [char] *) - | ISChar (** [signed char] *) - | IUChar (** [unsigned char] *) - | IInt (** [int] *) - | IUInt (** [unsigned int] *) - | IShort (** [short] *) - | IUShort (** [unsigned short] *) - | ILong (** [long] *) - | IULong (** [unsigned long] *) - | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) - | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft - Visual C) *) - -(** Various kinds of floating-point numbers*) -and fkind = - FFloat (** [float] *) - | FDouble (** [double] *) - | FLongDouble (** [long double] *) - -(** An attribute has a name and some optional parameters *) -and attribute = Attr of string * attrparam list - -(** Attributes are lists sorted by the attribute name *) -and attributes = attribute list - -(** The type of parameters in attributes *) -and attrparam = - | AInt of int (** An integer constant *) - | AStr of string (** A string constant *) - | ACons of string * attrparam list (** Constructed attributes. These - are printed [foo(a1,a2,...,an)]. - The list of parameters can be - empty and in that case the - parentheses are not printed. *) - | ASizeOf of typ (** A way to talk about types *) - | ASizeOfE of attrparam - | ASizeOfS of typsig (** Replacement for ASizeOf in type - signatures. Only used for - attributes inside typsigs.*) - | AAlignOf of typ - | AAlignOfE of attrparam - | AAlignOfS of typsig - | AUnOp of unop * attrparam - | ABinOp of binop * attrparam * attrparam - | ADot of attrparam * string (** a.foo **) - - -(** Information about a composite type (a struct or a union). Use - {!Cil.mkCompInfo} - to create non-recursive or (potentially) recursive versions of this. Make - sure you have a [GCompTag] for each one of these. *) -and compinfo = { - mutable cstruct: bool; (** True if struct, False if union *) - mutable cname: string; (** The name. Always non-empty. Use - * {!Cil.compFullName} to get the - * full name of a comp (along with - * the struct or union) *) - mutable ckey: int; (** A unique integer constructed from - * the name. Use {!Hashtbl.hash} on - * the string returned by - * {!Cil.compFullName}. All compinfo - * for a given key are shared. *) - mutable cfields: fieldinfo list; (** Information about the fields *) - mutable cattr: attributes; (** The attributes that are defined at - the same time as the composite - type *) - mutable cdefined: bool; (** Whether this is a defined - * compinfo. *) - mutable creferenced: bool; (** True if used. Initially set to - * false *) - } - -(** Information about a struct/union field *) -and fieldinfo = { - mutable fcomp: compinfo; (** The compinfo of the host. Note - that this must be shared with the - host since there can be only one - compinfo for a given id *) - mutable fname: string; (** The name of the field. Might be - * the value of - * {!Cil.missingFieldName} in which - * case it must be a bitfield and is - * not printed and it does not - * participate in initialization *) - mutable ftype: typ; (** The type *) - mutable fbitfield: int option; (** If a bitfield then ftype should be - an integer type *) - mutable fattr: attributes; (** The attributes for this field - * (not for its type) *) - mutable floc: location; (** The location where this field - * is defined *) -} - - - -(** Information about an enumeration. This is shared by all references to an - enumeration. Make sure you have a [GEnumTag] for each of of these. *) -and enuminfo = { - mutable ename: string; (** The name. Always non-empty *) - mutable eitems: (string * exp * location) list; (** Items with names - and values. This list - should be - non-empty. The item - values must be - compile-time - constants. *) - mutable eattr: attributes; (** Attributes *) - mutable ereferenced: bool; (** True if used. Initially set to false*) -} - -(** Information about a defined type *) -and typeinfo = { - mutable tname: string; - (** The name. Can be empty only in a [GType] when introducing a composite - * or enumeration tag. If empty cannot be refered to from the file *) - mutable ttype: typ; - (** The actual type. *) - mutable treferenced: bool; - (** True if used. Initially set to false*) -} - - -(** Information about a variable. These structures are shared by all - * references to the variable. So, you can change the name easily, for - * example. Use one of the {!Cil.makeLocalVar}, {!Cil.makeTempVar} or - * {!Cil.makeGlobalVar} to create instances of this data structure. *) -and varinfo = { - mutable vname: string; (** The name of the variable. Cannot - * be empty. *) - mutable vtype: typ; (** The declared type of the - * variable. *) - mutable vattr: attributes; (** A list of attributes associated - * with the variable. *) - mutable vstorage: storage; (** The storage-class *) - (* The other fields are not used in varinfo when they appear in the formal - * argument list in a [TFun] type *) - - - mutable vglob: bool; (** True if this is a global variable*) - - (** Whether this varinfo is for an inline function. *) - mutable vinline: bool; - - mutable vdecl: location; (** Location of variable declaration *) - - mutable vid: int; (** A unique integer identifier. *) - mutable vaddrof: bool; (** True if the address of this - variable is taken. CIL will set - * these flags when it parses C, but - * you should make sure to set the - * flag whenever your transformation - * create [AddrOf] expression. *) - - mutable vreferenced: bool; (** True if this variable is ever - referenced. This is computed by - [removeUnusedVars]. It is safe to - just initialize this to False *) -} - -(** Storage-class information *) -and storage = - NoStorage | (** The default storage. Nothing is - * printed *) - Static | - Register | - Extern - - -(** Expressions (Side-effect free)*) -and exp = - Const of constant (** Constant *) - | Lval of lval (** Lvalue *) - | SizeOf of typ (** sizeof(). Has [unsigned - * int] type (ISO 6.5.3.4). This is - * not turned into a constant because - * some transformations might want to - * change types *) - - | SizeOfE of exp (** sizeof() *) - | SizeOfStr of string - (** sizeof(string_literal). We separate this case out because this is the - * only instance in which a string literal should not be treated as - * having type pointer to character. *) - - | AlignOf of typ (** Has [unsigned int] type *) - | AlignOfE of exp - - - | UnOp of unop * exp * typ (** Unary operation. Includes - the type of the result *) - - | BinOp of binop * exp * exp * typ - (** Binary operation. Includes the - type of the result. The arithemtic - conversions are made explicit - for the arguments *) - | CastE of typ * exp (** Use {!Cil.mkCast} to make casts *) - - | AddrOf of lval (** Always use {!Cil.mkAddrOf} to - * construct one of these. Apply to an - * lvalue of type [T] yields an - * expression of type [TPtr(T)] *) - - | StartOf of lval (** There is no C correspondent for this. C has - * implicit coercions from an array to the address - * of the first element. [StartOf] is used in CIL to - * simplify type checking and is just an explicit - * form of the above mentioned implicit conversion. - * It is not printed. Given an lval of type - * [TArray(T)] produces an expression of type - * [TPtr(T)]. *) - - -(** Literal constants *) -and constant = - | CInt64 of int64 * ikind * string option - (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) - * and the textual representation, if available. Use - * {!Cil.integer} or {!Cil.kinteger} to create these. Watch - * out for integers that cannot be represented on 64 bits. - * OCAML does not give Overflow exceptions. *) - | CStr of string (** String constant (of pointer type) *) - | CWStr of int64 list (** Wide string constant (of type "wchar_t *") *) - | CChr of char (** Character constant. This has type int, so use - * charConstToInt to read the value in case - * sign-extension is needed. *) - | CReal of float * fkind * string option (** Floating point constant. Give - the fkind (see ISO 6.4.4.2) and - also the textual representation, - if available *) - | CEnum of exp * string * enuminfo - (** An enumeration constant with the given value, name, from the given - * enuminfo. This is not used if {!Cil.lowerEnum} is false (default). - * Use {!Cillower.lowerEnumVisitor} to replace these with integer - * constants. *) - -(** Unary operators *) -and unop = - Neg (** Unary minus *) - | BNot (** Bitwise complement (~) *) - | LNot (** Logical Not (!) *) - -(** Binary operations *) -and binop = - PlusA (** arithmetic + *) - | PlusPI (** pointer + integer *) - | IndexPI (** pointer + integer but only when - * it arises from an expression - * [e\[i\]] when [e] is a pointer and - * not an array. This is semantically - * the same as PlusPI but CCured uses - * this as a hint that the integer is - * probably positive. *) - | MinusA (** arithmetic - *) - | MinusPI (** pointer - integer *) - | MinusPP (** pointer - pointer *) - | Mult (** * *) - | Div (** / *) - | Mod (** % *) - | Shiftlt (** shift left *) - | Shiftrt (** shift right *) - - | Lt (** < (arithmetic comparison) *) - | Gt (** > (arithmetic comparison) *) - | Le (** <= (arithmetic comparison) *) - | Ge (** > (arithmetic comparison) *) - | Eq (** == (arithmetic comparison) *) - | Ne (** != (arithmetic comparison) *) - | BAnd (** bitwise and *) - | BXor (** exclusive-or *) - | BOr (** inclusive-or *) - - | LAnd (** logical and *) - | LOr (** logical or *) - - - - -(** An lvalue denotes the contents of a range of memory addresses. This range - * is denoted as a host object along with an offset within the object. The - * host object can be of two kinds: a local or global variable, or an object - * whose address is in a pointer expression. We distinguish the two cases so - * that we can tell quickly whether we are accessing some component of a - * variable directly or we are accessing a memory location through a pointer.*) -and lval = - lhost * offset - -(** The host part of an {!Cil.lval}. *) -and lhost = - | Var of varinfo - (** The host is a variable. *) - - | Mem of exp - (** The host is an object of type [T] when the expression has pointer - * [TPtr(T)]. *) - - -(** The offset part of an {!Cil.lval}. Each offset can be applied to certain - * kinds of lvalues and its effect is that it advances the starting address - * of the lvalue and changes the denoted type, essentially focussing to some - * smaller lvalue that is contained in the original one. *) -and offset = - | NoOffset (** No offset. Can be applied to any lvalue and does - * not change either the starting address or the type. - * This is used when the lval consists of just a host - * or as a terminator in a list of other kinds of - * offsets. *) - - | Field of fieldinfo * offset - (** A field offset. Can be applied only to an lvalue - * that denotes a structure or a union that contains - * the mentioned field. This advances the offset to the - * beginning of the mentioned field and changes the - * type to the type of the mentioned field. *) - - | Index of exp * offset - (** An array index offset. Can be applied only to an - * lvalue that denotes an array. This advances the - * starting address of the lval to the beginning of the - * mentioned array element and changes the denoted type - * to be the type of the array element *) - - - -(* The following equivalences hold *) -(* Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off *) -(* Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off *) -(* AddrOf (Mem a, NoOffset) = a *) - -(** Initializers for global variables. You can create an initializer with - * {!Cil.makeZeroInit}. *) -and init = - | SingleInit of exp (** A single initializer *) - | CompoundInit of typ * (offset * init) list - (** Used only for initializers of structures, unions and arrays. - * The offsets are all of the form [Field(f, NoOffset)] or - * [Index(i, NoOffset)] and specify the field or the index being - * initialized. For structures all fields - * must have an initializer (except the unnamed bitfields), in - * the proper order. This is necessary since the offsets are not - * printed. For arrays the list must contain a prefix of the - * initializers; the rest are 0-initialized. - * For unions there must be exactly one initializer. If - * the initializer is not for the first field then a field - * designator is printed, so you better be on GCC since MSVC does - * not understand this. You can scan an initializer list with - * {!Cil.foldLeftCompound}. *) - -(** We want to be able to update an initializer in a global variable, so we - * define it as a mutable field *) -and initinfo = { - mutable init : init option; - } - - -(** Function definitions. *) -and fundec = - { mutable svar: varinfo; - (** Holds the name and type as a variable, so we can refer to it - * easily from the program. All references to this function either - * in a function call or in a prototype must point to the same - * varinfo. *) - mutable sformals: varinfo list; - (** Formals. These must be shared with the formals that appear in the - * type of the function. Use {!Cil.setFormals} or - * {!Cil.setFunctionType} to set these - * formals and ensure that they are reflected in the function type. - * Do not make copies of these because the body refers to them. *) - mutable slocals: varinfo list; - (** Locals. Does not include the sformals. Do not make copies of - * these because the body refers to them. *) - mutable smaxid: int; (** Max local id. Starts at 0. *) - mutable sbody: block; (** The function body. *) - mutable smaxstmtid: int option; (** max id of a (reachable) statement - * in this function, if we have - * computed it. range = 0 ... - * (smaxstmtid-1). This is computed by - * {!Cil.computeCFGInfo}. *) - mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} - * this field is set to contain all - * statements in the function *) - } - - -(** A block is a sequence of statements with the control falling through from - one element to the next *) -and block = - { mutable battrs: attributes; (** Attributes for the block *) - mutable bstmts: stmt list; (** The statements comprising the block*) - } - - -(** Statements. - The statement is the structural unit in the control flow graph. Use mkStmt - to make a statement and then fill in the fields. *) -and stmt = { - mutable labels: label list; (** Whether the statement starts with - some labels, case statements or - default statement *) - mutable skind: stmtkind; (** The kind of statement *) - - (* Now some additional control flow information. Initially this is not - * filled in. *) - mutable sid: int; (** A number (>= 0) that is unique - in a function. *) - mutable succs: stmt list; (** The successor statements. They can - always be computed from the skind - and the context in which this - statement appears *) - mutable preds: stmt list; (** The inverse of the succs function*) - } - -(** Labels *) -and label = - Label of string * location * bool - (** A real label. If the bool is "true", the label is from the - * input source program. If the bool is "false", the label was - * created by CIL or some other transformation *) - | Case of exp * location (** A case statement *) - | Default of location (** A default statement *) - - - -(* The various kinds of statements *) -and stmtkind = - | Instr of instr list (** A group of instructions that do not - contain control flow. Control - implicitly falls through. *) - | Return of exp option * location (** The return statement. This is a - leaf in the CFG. *) - - | Goto of stmt ref * location (** A goto statement. Appears from - actual goto's in the code. *) - | Break of location (** A break to the end of the nearest - enclosing loop or Switch *) - | Continue of location (** A continue to the start of the - nearest enclosing loop *) - | If of exp * block * block * location (** A conditional. - Two successors, the "then" and - the "else" branches. Both - branches fall-through to the - successor of the If statement *) - | Switch of exp * block * (stmt list) * location - (** A switch statement. The block - contains within all of the cases. - We also have direct pointers to the - statements that implement the - cases. Which cases they implement - you can get from the labels of the - statement *) - -(* - | Loop of block * location * (stmt option) * (stmt option) - (** A [while(1)] loop. The - * termination test is implemented - * in the body of a loop using a - * [Break] statement. If - * prepareCFG has been called, the - * first stmt option will point to - * the stmt containing the - * continue label for this loop - * and the second will point to - * the stmt containing the break - * label for this loop. *) -*) - | While of exp * block * location (** A while loop. *) - | DoWhile of exp * block * location (** A do...while loop. *) - | For of block * exp * block * block * location (** A for loop. *) - - | Block of block (** Just a block of statements. Use it - as a way to keep some attributes - local *) - (** On MSVC we support structured exception handling. This is what you - * might expect. Control can get into the finally block either from the - * end of the body block, or if an exception is thrown. The location - * corresponds to the try keyword. *) - | TryFinally of block * block * location - - (** On MSVC we support structured exception handling. The try/except - * statement is a bit tricky: - __try { blk } - __except (e) { - handler - } - - The argument to __except must be an expression. However, we keep a - list of instructions AND an expression in case you need to make - function calls. We'll print those as a comma expression. The control - can get to the __except expression only if an exception is thrown. - After that, depending on the value of the expression the control - goes to the handler, propagates the exception, or retries the - exception !!! The location corresponds to the try keyword. - *) - | TryExcept of block * (instr list * exp) * block * location - - -(** Instructions. They may cause effects directly but may not have control - flow.*) -and instr = - Set of lval * exp * location (** An assignment. A cast is present - if the exp has different type - from lval *) - | Call of lval option * exp * exp list * location - (** optional: result is an lval. A cast might be - necessary if the declared result type of the - function is not the same as that of the - destination. If the function is declared then - casts are inserted for those arguments that - correspond to declared formals. (The actual - number of arguments might be smaller or larger - than the declared number of arguments. C allows - this.) If the type of the result variable is not - the same as the declared type of the function - result then an implicit cast exists. *) - - (* See the GCC specification for the meaning of ASM. - * If the source is MS VC then only the templates - * are used *) - (* sm: I've added a notes.txt file which contains more - * information on interpreting Asm instructions *) - | Asm of attributes * (* Really only const and volatile can appear - * here *) - string list * (* templates (CR-separated) *) - (string * lval) list * (* outputs must be lvals with - * constraints. I would like these - * to be actually variables, but I - * run into some trouble with ASMs - * in the Linux sources *) - (string * exp) list * (* inputs with constraints *) - string list * (* register clobbers *) - location - (** An inline assembly instruction. The arguments are (1) a list of - attributes (only const and volatile can appear here and only for - GCC), (2) templates (CR-separated), (3) a list of - outputs, each of which is an lvalue with a constraint, (4) a list - of input expressions along with constraints, (5) clobbered - registers, and (5) location information *) - - - -(** Describes a location in a source file *) -and location = { - line: int; (** The line number. -1 means "do not know" *) - file: string; (** The name of the source file*) - byte: int; (** The byte position in the source file *) -} - -(* Type signatures. Two types are identical iff they have identical - * signatures *) -and typsig = - TSArray of typsig * int64 option * attribute list - | TSPtr of typsig * attribute list - | TSComp of bool * string * attribute list - | TSFun of typsig * typsig list * bool * attribute list - | TSEnum of string * attribute list - | TSBase of typ - - - -(** To be able to add/remove features easily, each feature should be package - * as an interface with the following interface. These features should be *) -type featureDescr = { - fd_enabled: bool ref; - (** The enable flag. Set to default value *) - - fd_name: string; - (** This is used to construct an option "--doxxx" and "--dontxxx" that - * enable and disable the feature *) - - fd_description: string; - (* A longer name that can be used to document the new options *) - - fd_extraopt: (string * Arg.spec * string) list; - (** Additional command line options *) - - fd_doit: (file -> unit); - (** This performs the transformation *) - - fd_post_check: bool; - (* Whether to perform a CIL consistency checking after this stage, if - * checking is enabled (--check is passed to cilly) *) -} - -let locUnknown = { line = -1; - file = ""; - byte = -1;} - -(* A reference to the current location *) -let currentLoc : location ref = ref locUnknown - -(* A reference to the current global being visited *) -let currentGlobal: global ref = ref (GText "dummy") - - -let compareLoc (a: location) (b: location) : int = - let namecmp = compare a.file b.file in - if namecmp != 0 - then namecmp - else - let linecmp = a.line - b.line in - if linecmp != 0 - then linecmp - else a.byte - b.byte - -let argsToList : (string * typ * attributes) list option - -> (string * typ * attributes) list - = function - None -> [] - | Some al -> al - - -(* A hack to allow forward reference of d_exp *) -let pd_exp : (unit -> exp -> doc) ref = - ref (fun _ -> E.s (E.bug "pd_exp not initialized")) - -(** Different visiting actions. 'a will be instantiated with [exp], [instr], - etc. *) -type 'a visitAction = - SkipChildren (** Do not visit the children. Return - the node as it is. *) - | DoChildren (** Continue with the children of this - node. Rebuild the node on return - if any of the children changes - (use == test) *) - | ChangeTo of 'a (** Replace the expression with the - given one *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire - exp is replaced by the first - parameter. Then continue with - the children. On return rebuild - the node if any of the children - has changed and then apply the - function on the node *) - - - -(* sm/gn: cil visitor interface for traversing Cil trees. *) -(* Use visitCilStmt and/or visitCilFile to use this. *) -(* Some of the nodes are changed in place if the children are changed. Use - * one of Change... actions if you want to copy the node *) - -(** A visitor interface for traversing CIL trees. Create instantiations of - * this type by specializing the class {!Cil.nopCilVisitor}. *) -class type cilVisitor = object - - method vvdec: varinfo -> varinfo visitAction - (** Invoked for each variable declaration. The subtrees to be traversed - * are those corresponding to the type and attributes of the variable. - * Note that variable declarations are all the [GVar], [GVarDecl], [GFun], - * all the [varinfo] in formals of function types, and the formals and - * locals for function definitions. This means that the list of formals - * in a function definition will be traversed twice, once as part of the - * function type and second as part of the formals in a function - * definition. *) - - method vvrbl: varinfo -> varinfo visitAction - (** Invoked on each variable use. Here only the [SkipChildren] and - * [ChangeTo] actions make sense since there are no subtrees. Note that - * the type and attributes of the variable are not traversed for a - * variable use *) - - method vexpr: exp -> exp visitAction - (** Invoked on each expression occurence. The subtrees are the - * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the - * variable use. *) - - method vlval: lval -> lval visitAction - (** Invoked on each lvalue occurence *) - - method voffs: offset -> offset visitAction - (** Invoked on each offset occurrence that is *not* as part - * of an initializer list specification, i.e. in an lval or - * recursively inside an offset. *) - - method vinitoffs: offset -> offset visitAction - (** Invoked on each offset appearing in the list of a - * CompoundInit initializer. *) - - method vinst: instr -> instr list visitAction - (** Invoked on each instruction occurrence. The [ChangeTo] action can - * replace this instruction with a list of instructions *) - - method vstmt: stmt -> stmt visitAction - (** Control-flow statement. *) - - method vblock: block -> block visitAction (** Block. Replaced in - place. *) - method vfunc: fundec -> fundec visitAction (** Function definition. - Replaced in place. *) - method vglob: global -> global list visitAction (** Global (vars, types, - etc.) *) - method vinit: init -> init visitAction (** Initializers for globals *) - method vtype: typ -> typ visitAction (** Use of some type. Note - * that for structure/union - * and enumeration types the - * definition of the - * composite type is not - * visited. Use [vglob] to - * visit it. *) - method vattr: attribute -> attribute list visitAction - (** Attribute. Each attribute can be replaced by a list *) - method vattrparam: attrparam -> attrparam visitAction - (** Attribute parameters. *) - - (** Add here instructions while visiting to queue them to - * preceede the current statement or instruction being processed *) - method queueInstr: instr list -> unit - - (** Gets the queue of instructions and resets the queue *) - method unqueueInstr: unit -> instr list - -end - -(* the default visitor does nothing at each node, but does *) -(* not stop; hence they return true *) -class nopCilVisitor : cilVisitor = object - method vvrbl (v:varinfo) = DoChildren (* variable *) - method vvdec (v:varinfo) = DoChildren (* variable - * declaration *) - method vexpr (e:exp) = DoChildren (* expression *) - method vlval (l:lval) = DoChildren (* lval (base is 1st - * field) *) - method voffs (o:offset) = DoChildren (* lval or recursive offset *) - method vinitoffs (o:offset) = DoChildren (* initializer offset *) - method vinst (i:instr) = DoChildren (* imperative instruction *) - method vstmt (s:stmt) = DoChildren (* constrol-flow statement *) - method vblock (b: block) = DoChildren - method vfunc (f:fundec) = DoChildren (* function definition *) - method vglob (g:global) = DoChildren (* global (vars, types, etc.) *) - method vinit (i:init) = DoChildren (* global initializers *) - method vtype (t:typ) = DoChildren (* use of some type *) - method vattr (a: attribute) = DoChildren - method vattrparam (a: attrparam) = DoChildren - - val mutable instrQueue = [] - - method queueInstr (il: instr list) = - List.iter (fun i -> instrQueue <- i :: instrQueue) il - - method unqueueInstr () = - let res = List.rev instrQueue in - instrQueue <- []; - res - -end - -let assertEmptyQueue vis = - if vis#unqueueInstr () <> [] then - (* Either a visitor inserted an instruction somewhere that it shouldn't - have (i.e. at the top level rather than inside of a statement), or - there's a bug in the visitor engine. *) - E.s (E.bug "Visitor's instruction queue is not empty.\n You should only use queueInstr inside a function body!"); - () - - -let lu = locUnknown - -(* sm: utility *) -let startsWith (prefix: string) (s: string) : bool = -( - let prefixLen = (String.length prefix) in - (String.length s) >= prefixLen && - (String.sub s 0 prefixLen) = prefix -) - - -let get_instrLoc (inst : instr) = - match inst with - Set(_, _, loc) -> loc - | Call(_, _, _, loc) -> loc - | Asm(_, _, _, _, _, loc) -> loc -let get_globalLoc (g : global) = - match g with - | GFun(_,l) -> (l) - | GType(_,l) -> (l) - | GEnumTag(_,l) -> (l) - | GEnumTagDecl(_,l) -> (l) - | GCompTag(_,l) -> (l) - | GCompTagDecl(_,l) -> (l) - | GVarDecl(_,l) -> (l) - | GVar(_,_,l) -> (l) - | GAsm(_,l) -> (l) - | GPragma(_,l) -> (l) - | GText(_) -> locUnknown - -let rec get_stmtLoc (statement : stmtkind) = - match statement with - Instr([]) -> lu - | Instr(hd::tl) -> get_instrLoc(hd) - | Return(_, loc) -> loc - | Goto(_, loc) -> loc - | Break(loc) -> loc - | Continue(loc) -> loc - | If(_, _, _, loc) -> loc - | Switch (_, _, _, loc) -> loc -(* - | Loop (_, loc, _, _) -> loc -*) - | While (_, _, loc) -> loc - | DoWhile (_, _, loc) -> loc - | For (_, _, _, _, loc) -> loc - | Block b -> if b.bstmts == [] then lu - else get_stmtLoc ((List.hd b.bstmts).skind) - | TryFinally (_, _, l) -> l - | TryExcept (_, _, _, l) -> l - - -(* The next variable identifier to use. Counts up *) -let nextGlobalVID = ref 1 - -(* The next compindo identifier to use. Counts up. *) -let nextCompinfoKey = ref 1 - -(* Some error reporting functions *) -let d_loc (_: unit) (loc: location) : doc = - text loc.file ++ chr ':' ++ num loc.line - -let d_thisloc (_: unit) : doc = d_loc () !currentLoc - -let error (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "@!%t: Error: %a@!" - d_thisloc insert d); - nil - in - Pretty.gprintf f fmt - -let unimp (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "@!%t: Unimplemented: %a@!" - d_thisloc insert d); - nil - in - Pretty.gprintf f fmt - -let bug (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "@!%t: Bug: %a@!" - d_thisloc insert d); - E.showContext (); - nil - in - Pretty.gprintf f fmt - -let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = - let f d = - E.hadErrors := true; - ignore (eprintf "@!%a: Error: %a@!" - d_loc loc insert d); - E.showContext (); - nil - in - Pretty.gprintf f fmt - -let warn (fmt : ('a,unit,doc) format) : 'a = - let f d = - ignore (eprintf "@!%t: Warning: %a@!" - d_thisloc insert d); - nil - in - Pretty.gprintf f fmt - - -let warnOpt (fmt : ('a,unit,doc) format) : 'a = - let f d = - if !E.warnFlag then - ignore (eprintf "@!%t: Warning: %a@!" - d_thisloc insert d); - nil - in - Pretty.gprintf f fmt - -let warnContext (fmt : ('a,unit,doc) format) : 'a = - let f d = - ignore (eprintf "@!%t: Warning: %a@!" - d_thisloc insert d); - E.showContext (); - nil - in - Pretty.gprintf f fmt - -let warnContextOpt (fmt : ('a,unit,doc) format) : 'a = - let f d = - if !E.warnFlag then - ignore (eprintf "@!%t: Warning: %a@!" - d_thisloc insert d); - E.showContext (); - nil - in - Pretty.gprintf f fmt - -let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = - let f d = - ignore (eprintf "@!%a: Warning: %a@!" - d_loc loc insert d); - E.showContext (); - nil - in - Pretty.gprintf f fmt - - - -(* Construct an integer. Use only for values that fit on 31 bits. - For larger values, use kinteger *) -let integer (i: int) = Const (CInt64(Int64.of_int i, IInt, None)) - -let zero = integer 0 -let one = integer 1 -let mone = integer (-1) - -(** Given the character c in a (CChr c), sign-extend it to 32 bits. - (This is the official way of interpreting character constants, according to - ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) - Returns CInt64(sign-extened c, IInt, None) *) -let charConstToInt (c: char) : constant = - let c' = Char.code c in - let value = - if c' < 128 - then Int64.of_int c' - else Int64.of_int (c' - 256) - in - CInt64(value, IInt, None) - - -let rec isInteger = function - | Const(CInt64 (n,_,_)) -> Some n - | Const(CChr c) -> isInteger (Const (charConstToInt c)) (* sign-extend *) - | Const(CEnum(v, s, ei)) -> isInteger v - | CastE(_, e) -> isInteger e - | _ -> None - - - -let rec isZero (e: exp) : bool = isInteger e = Some Int64.zero - -let voidType = TVoid([]) -let intType = TInt(IInt,[]) -let uintType = TInt(IUInt,[]) -let longType = TInt(ILong,[]) -let ulongType = TInt(IULong,[]) -let charType = TInt(IChar, []) - -let charPtrType = TPtr(charType,[]) -let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[]) -let stringLiteralType = ref charPtrType - -let voidPtrType = TPtr(voidType, []) -let intPtrType = TPtr(intType, []) -let uintPtrType = TPtr(uintType, []) - -let doubleType = TFloat(FDouble, []) - - -(* An integer type that fits pointers. Initialized by initCIL *) -let upointType = ref voidType - -(* An integer type that fits wchar_t. Initialized by initCIL *) -let wcharKind = ref IChar -let wcharType = ref voidType - - -(* An integer type that is the type of sizeof. Initialized by initCIL *) -let typeOfSizeOf = ref voidType -let kindOfSizeOf = ref IUInt - -let initCIL_called = ref false - -(** Returns true if and only if the given integer type is signed. *) -let isSigned = function - | IUChar - | IUShort - | IUInt - | IULong - | IULongLong -> - false - | ISChar - | IShort - | IInt - | ILong - | ILongLong -> - true - | IChar -> - not !theMachine.M.char_is_unsigned - -let mkStmt (sk: stmtkind) : stmt = - { skind = sk; - labels = []; - sid = -1; succs = []; preds = [] } - -let mkBlock (slst: stmt list) : block = - { battrs = []; bstmts = slst; } - -let mkEmptyStmt () = mkStmt (Instr []) -let mkStmtOneInstr (i: instr) = mkStmt (Instr [i]) - -let dummyInstr = (Asm([], ["dummy statement!!"], [], [], [], lu)) -let dummyStmt = mkStmt (Instr [dummyInstr]) - -let compactStmts (b: stmt list) : stmt list = - (* Try to compress statements. Scan the list of statements and remember - * the last instrunction statement encountered, along with a Clist of - * instructions in it. *) - let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *) - (lastinstrs: instr Clist.clist) - (body: stmt list) = - let finishLast (tail: stmt list) : stmt list = - if lastinstrstmt == dummyStmt then tail - else begin - lastinstrstmt.skind <- Instr (Clist.toList lastinstrs); - lastinstrstmt :: tail - end - in - match body with - [] -> finishLast [] - | ({skind=Instr il} as s) :: rest -> - let ils = Clist.fromList il in - if lastinstrstmt != dummyStmt && s.labels == [] then - compress lastinstrstmt (Clist.append lastinstrs ils) rest - else - finishLast (compress s ils rest) - - | s :: rest -> - let res = s :: compress dummyStmt Clist.empty rest in - finishLast res - in - compress dummyStmt Clist.empty b - - -(** Construct sorted lists of attributes ***) -let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) = - let rec insertSorted = function - [] -> [a] - | ((Attr(an0, _) as a0) :: rest) as l -> - if an < an0 then a :: l - else if Util.equals a a0 then l (* Do not add if already in there *) - else a0 :: insertSorted rest (* Make sure we see all attributes with - * this name *) - in - insertSorted al - -(** The second attribute list is sorted *) -and addAttributes al0 (al: attributes) : attributes = - if al0 == [] then al else - List.fold_left (fun acc a -> addAttribute a acc) al al0 - -and dropAttribute (an: string) (al: attributes) = - List.filter (fun (Attr(an', _)) -> an <> an') al - -and dropAttributes (anl: string list) (al: attributes) = - List.fold_left (fun acc an -> dropAttribute an acc) al anl - -and filterAttributes (s: string) (al: attribute list) : attribute list = - List.filter (fun (Attr(an, _)) -> an = s) al - -(* sm: *) -let hasAttribute s al = - (filterAttributes s al <> []) - - -type attributeClass = - AttrName of bool - (* Attribute of a name. If argument is true and we are on MSVC then - * the attribute is printed using __declspec as part of the storage - * specifier *) - | AttrFunType of bool - (* Attribute of a function type. If argument is true and we are on - * MSVC then the attribute is printed just before the function name *) - - | AttrType (* Attribute of a type *) - -(* This table contains the mapping of predefined attributes to classes. - * Extend this table with more attributes as you need. This table is used to - * determine how to associate attributes with names or type during cabs2cil - * conversion *) -let attributeHash: (string, attributeClass) H.t = - let table = H.create 13 in - List.iter (fun a -> H.add table a (AttrName false)) - [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak"; - "no_instrument_function"; "alias"; "no_check_memory_usage"; - "exception"; "model"; (* "restrict"; *) - "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in - * assembly for a global *)]; - - (* Now come the MSVC declspec attributes *) - List.iter (fun a -> H.add table a (AttrName true)) - [ "thread"; "naked"; "dllimport"; "dllexport"; - "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn"; - "uuid"; "align" ]; - - List.iter (fun a -> H.add table a (AttrFunType false)) - [ "format"; "regparm"; "longcall"; - "noinline"; "always_inline"; ]; - - List.iter (fun a -> H.add table a (AttrFunType true)) - [ "stdcall";"cdecl"; "fastcall" ]; - - List.iter (fun a -> H.add table a AttrType) - [ "const"; "volatile"; "restrict"; "mode" ]; - table - - -(* Partition the attributes into classes *) -let partitionAttributes - ~(default:attributeClass) - (attrs: attribute list) : - attribute list * attribute list * attribute list = - let rec loop (n,f,t) = function - [] -> n, f, t - | (Attr(an, _) as a) :: rest -> - match (try H.find attributeHash an with Not_found -> default) with - AttrName _ -> loop (addAttribute a n, f, t) rest - | AttrFunType _ -> - loop (n, addAttribute a f, t) rest - | AttrType -> loop (n, f, addAttribute a t) rest - in - loop ([], [], []) attrs - - -(* Get the full name of a comp *) -let compFullName comp = - (if comp.cstruct then "struct " else "union ") ^ comp.cname - - -let missingFieldName = "___missing_field_name" - -(** Creates a a (potentially recursive) composite type. Make sure you add a - * GTag for it to the file! **) -let mkCompInfo - (isstruct: bool) - (n: string) - (* fspec is a function that when given a forward - * representation of the structure type constructs the type of - * the fields. The function can ignore this argument if not - * constructing a recursive type. *) - (mkfspec: compinfo -> (string * typ * int option * attribute list * - location) list) - (a: attribute list) : compinfo = - - (* make an new name for anonymous structs *) - if n = "" then - E.s (E.bug "mkCompInfo: missing structure name\n"); - (* Make a new self cell and a forward reference *) - let comp = - { cstruct = isstruct; cname = ""; ckey = 0; cfields = []; - cattr = a; creferenced = false; - (* Make this compinfo undefined by default *) - cdefined = false; } - in - comp.cname <- n; - comp.ckey <- !nextCompinfoKey; - incr nextCompinfoKey; - let flds = - List.map (fun (fn, ft, fb, fa, fl) -> - { fcomp = comp; - ftype = ft; - fname = fn; - fbitfield = fb; - fattr = fa; - floc = fl}) (mkfspec comp) in - comp.cfields <- flds; - if flds <> [] then comp.cdefined <- true; - comp - -(** Make a copy of a compinfo, changing the name and the key *) -let copyCompInfo (ci: compinfo) (n: string) : compinfo = - let ci' = {ci with cname = n; - ckey = !nextCompinfoKey; } in - incr nextCompinfoKey; - (* Copy the fields and set the new pointers to parents *) - ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields; - ci' - -(**** Utility functions ******) - -let rec typeAttrs = function - TVoid a -> a - | TInt (_, a) -> a - | TFloat (_, a) -> a - | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype) - | TPtr (_, a) -> a - | TArray (_, _, a) -> a - | TComp (comp, a) -> addAttributes comp.cattr a - | TEnum (enum, a) -> addAttributes enum.eattr a - | TFun (_, _, _, a) -> a - | TBuiltin_va_list a -> a - - -let setTypeAttrs t a = - match t with - TVoid _ -> TVoid a - | TInt (i, _) -> TInt (i, a) - | TFloat (f, _) -> TFloat (f, a) - | TNamed (t, _) -> TNamed(t, a) - | TPtr (t', _) -> TPtr(t', a) - | TArray (t', l, _) -> TArray(t', l, a) - | TComp (comp, _) -> TComp (comp, a) - | TEnum (enum, _) -> TEnum (enum, a) - | TFun (r, args, v, _) -> TFun(r,args,v,a) - | TBuiltin_va_list _ -> TBuiltin_va_list a - - -let typeAddAttributes a0 t = -begin - match a0 with - | [] -> - (* no attributes, keep same type *) - t - | _ -> - (* anything else: add a0 to existing attributes *) - let add (a: attributes) = addAttributes a0 a in - match t with - TVoid a -> TVoid (add a) - | TInt (ik, a) -> TInt (ik, add a) - | TFloat (fk, a) -> TFloat (fk, add a) - | TEnum (enum, a) -> TEnum (enum, add a) - | TPtr (t, a) -> TPtr (t, add a) - | TArray (t, l, a) -> TArray (t, l, add a) - | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) - | TComp (comp, a) -> TComp (comp, add a) - | TNamed (t, a) -> TNamed (t, add a) - | TBuiltin_va_list a -> TBuiltin_va_list (add a) -end - -let typeRemoveAttributes (anl: string list) t = - let drop (al: attributes) = dropAttributes anl al in - match t with - TVoid a -> TVoid (drop a) - | TInt (ik, a) -> TInt (ik, drop a) - | TFloat (fk, a) -> TFloat (fk, drop a) - | TEnum (enum, a) -> TEnum (enum, drop a) - | TPtr (t, a) -> TPtr (t, drop a) - | TArray (t, l, a) -> TArray (t, l, drop a) - | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a) - | TComp (comp, a) -> TComp (comp, drop a) - | TNamed (t, a) -> TNamed (t, drop a) - | TBuiltin_va_list a -> TBuiltin_va_list (drop a) - -let unrollType (t: typ) : typ = - let rec withAttrs (al: attributes) (t: typ) : typ = - match t with - TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype - | x -> typeAddAttributes al x - in - withAttrs [] t - -let rec unrollTypeDeep (t: typ) : typ = - let rec withAttrs (al: attributes) (t: typ) : typ = - match t with - TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype - | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a') - | TArray(t, l, a') -> TArray(unrollTypeDeep t, l, addAttributes al a') - | TFun(rt, args, isva, a') -> - TFun (unrollTypeDeep rt, - (match args with - None -> None - | Some argl -> - Some (List.map (fun (an,at,aa) -> - (an, unrollTypeDeep at, aa)) argl)), - isva, - addAttributes al a') - | x -> typeAddAttributes al x - in - withAttrs [] t - -let isVoidType t = - match unrollType t with - TVoid _ -> true - | _ -> false -let isVoidPtrType t = - match unrollType t with - TPtr(tau,_) when isVoidType tau -> true - | _ -> false - -let var vi : lval = (Var vi, NoOffset) -(* let assign vi e = Instrs(Set (var vi, e), lu) *) - -let mkString s = Const(CStr s) - - -let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list = - (* Do it like this so that the pretty printer recognizes it *) -(* - [ mkStmt (Loop (mkBlock (mkStmt (If(guard, - mkBlock [ mkEmptyStmt () ], - mkBlock [ mkStmt (Break lu)], lu)) :: - body), lu, None, None)) ] -*) - [ mkStmt (While (guard, mkBlock body, lu)) ] - - - -let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list) - ~(body: stmt list) : stmt list = - (start @ - (mkWhile guard (body @ next))) - - -let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp) - ~(body: stmt list) : stmt list = - (* See what kind of operator we need *) - let compop, nextop = - match unrollType iter.vtype with - TPtr _ -> Lt, PlusPI - | _ -> Lt, PlusA - in - mkFor - [ mkStmt (Instr [(Set (var iter, first, lu))]) ] - (BinOp(compop, Lval(var iter), past, intType)) - [ mkStmt (Instr [(Set (var iter, - (BinOp(nextop, Lval(var iter), incr, iter.vtype)), - lu))])] - body - - -let rec stripCasts (e: exp) = - match e with CastE(_, e') -> stripCasts e' | _ -> e - - - -(* the name of the C function we call to get ccgr ASTs -external parse : string -> file = "cil_main" -*) -(* - Pretty Printing - *) - -let d_ikind () = function - IChar -> text "char" - | ISChar -> text "signed char" - | IUChar -> text "unsigned char" - | IInt -> text "int" - | IUInt -> text "unsigned int" - | IShort -> text "short" - | IUShort -> text "unsigned short" - | ILong -> text "long" - | IULong -> text "unsigned long" - | ILongLong -> - if !msvcMode then text "__int64" else text "long long" - | IULongLong -> - if !msvcMode then text "unsigned __int64" - else text "unsigned long long" - -let d_fkind () = function - FFloat -> text "float" - | FDouble -> text "double" - | FLongDouble -> text "long double" - -let d_storage () = function - NoStorage -> nil - | Static -> text "static " - | Extern -> text "extern " - | Register -> text "register " - -(* sm: need this value below *) -let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000") -let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000") - -(* constant *) -let d_const () c = - match c with - CInt64(_, _, Some s) -> text s (* Always print the text if there is one *) - | CInt64(i, ik, None) -> - (** We must make sure to capture the type of the constant. For some - * constants this is done with a suffix, for others with a cast prefix.*) - let suffix : string = - match ik with - IUInt -> "U" - | ILong -> "L" - | IULong -> "UL" - | ILongLong -> if !msvcMode then "L" else "LL" - | IULongLong -> if !msvcMode then "UL" else "ULL" - | _ -> "" - in - let prefix : string = - if suffix <> "" then "" - else if ik = IInt then "" - else "(" ^ (sprint !lineLength (d_ikind () ik)) ^ ")" - in - (* Watch out here for negative integers that we should be printing as - * large positive ones *) - if i < Int64.zero - && (match ik with - IUInt | IULong | IULongLong | IUChar | IUShort -> true | _ -> false) then - let high = Int64.shift_right i 32 in - if ik <> IULongLong && ik <> ILongLong && high = Int64.of_int (-1) then - (* Print only the low order 32 bits *) - text (prefix ^ "0x" ^ - (Int64.format "%x" - (Int64.logand i (Int64.shift_right_logical high 32)) - ^ suffix)) - else - text (prefix ^ "0x" ^ Int64.format "%x" i ^ suffix) - else ( - if (i = mostNeg32BitInt) then - (* sm: quirk here: if you print -2147483648 then this is two tokens *) - (* in C, and the second one is too large to represent in a signed *) - (* int.. so we do what's done in limits.h, and print (-2147483467-1); *) - (* in gcc this avoids a warning, but it might avoid a real problem *) - (* on another compiler or a 64-bit architecture *) - text (prefix ^ "(-0x7FFFFFFF-1)") - else if (i = mostNeg64BitInt) then - (* The same is true of the largest 64-bit negative. *) - text (prefix ^ "(-0x7FFFFFFFFFFFFFFF-1)") - else - text (prefix ^ (Int64.to_string i ^ suffix)) - ) - - | CStr(s) -> text ("\"" ^ escape_string s ^ "\"") - | CWStr(s) -> - (* text ("L\"" ^ escape_string s ^ "\"") *) - (List.fold_left (fun acc elt -> - acc ++ - if (elt >= Int64.zero && - elt <= (Int64.of_int 255)) then - text (escape_char (Char.chr (Int64.to_int elt))) - else - ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++ - (text "\"")) - ) (text "L\"") s ) ++ text "\"" - (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" -- - * the former has 7 wide characters and the later has 3. *) - - | CChr(c) -> text ("'" ^ escape_char c ^ "'") - | CReal(_, _, Some s) -> text s - | CReal(f, _, None) -> text (string_of_float f) - | CEnum(_, s, ei) -> text s - - -(* Parentheses level. An expression "a op b" is printed parenthesized if its - * parentheses level is >= that that of its context. Identifiers have the - * lowest level and weakly binding operators (e.g. |) have the largest level. - * The correctness criterion is that a smaller level MUST correspond to a - * stronger precedence! - *) -let derefStarLevel = 20 -let indexLevel = 20 -let arrowLevel = 20 -let addrOfLevel = 30 -let additiveLevel = 60 -let comparativeLevel = 70 -let bitwiseLevel = 75 -let getParenthLevel = function - | BinOp((LAnd | LOr), _,_,_) -> 80 - (* Bit operations. *) - | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *) - - (* Comparisons *) - | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) -> - comparativeLevel (* 70 *) - (* Additive. Shifts can have higher - * level than + or - but I want - * parentheses around them *) - | BinOp((MinusA|MinusPP|MinusPI|PlusA| - PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_) - -> additiveLevel (* 60 *) - - (* Multiplicative *) - | BinOp((Div|Mod|Mult),_,_,_) -> 40 - - (* Unary *) - | CastE(_,_) -> 30 - | AddrOf(_) -> 30 - | StartOf(_) -> 30 - | UnOp((Neg|BNot|LNot),_,_) -> 30 - - (* Lvals *) - | Lval(Mem _ , _) -> 20 - | Lval(Var _, (Field _|Index _)) -> 20 - | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20 - | AlignOf _ | AlignOfE _ -> 20 - - | Lval(Var _, NoOffset) -> 0 (* Plain variables *) - | Const _ -> 0 (* Constants *) - - - -(* Separate out the storage-modifier name attributes *) -let separateStorageModifiers (al: attribute list) = - let isstoragemod (Attr(an, _): attribute) : bool = - try - match H.find attributeHash an with - AttrName issm -> issm - | _ -> E.s (E.bug "separateStorageModifier: %s is not a name attribute" an) - with Not_found -> false - in - let stom, rest = List.partition isstoragemod al in - if not !msvcMode then - stom, rest - else - (* Put back the declspec. Put it without the leading __ since these will - * be added later *) - let stom' = - List.map (fun (Attr(an, args)) -> - Attr("declspec", [ACons(an, args)])) stom in - stom', rest - - -let isIntegralType t = - match unrollType t with - (TInt _ | TEnum _) -> true - | _ -> false - -let isArithmeticType t = - match unrollType t with - (TInt _ | TEnum _ | TFloat _) -> true - | _ -> false - - -let isPointerType t = - match unrollType t with - TPtr _ -> true - | _ -> false - -let isFunctionType t = - match unrollType t with - TFun _ -> true - | _ -> false - -(**** Compute the type of an expression ****) -let rec typeOf (e: exp) : typ = - match e with - | Const(CInt64 (_, ik, _)) -> TInt(ik, []) - - (* Character constants have type int. ISO/IEC 9899:1999 (E), - * section 6.4.4.4 [Character constants], paragraph 10, if you - * don't believe me. *) - | Const(CChr _) -> intType - - (* The type of a string is a pointer to characters ! The only case when - * you would want it to be an array is as an argument to sizeof, but we - * have SizeOfStr for that *) - | Const(CStr s) -> !stringLiteralType - - | Const(CWStr s) -> TPtr(!wcharType,[]) - - | Const(CReal (_, fk, _)) -> TFloat(fk, []) - - | Const(CEnum(_, _, ei)) -> TEnum(ei, []) - - | Lval(lv) -> typeOfLval lv - | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf - | AlignOf _ | AlignOfE _ -> !typeOfSizeOf - | UnOp (_, _, t) -> t - | BinOp (_, _, _, t) -> t - | CastE (t, _) -> t - | AddrOf (lv) -> TPtr(typeOfLval lv, []) - | StartOf (lv) -> begin - match unrollType (typeOfLval lv) with - TArray (t,_, _) -> TPtr(t, []) - | _ -> E.s (E.bug "typeOf: StartOf on a non-array") - end - -and typeOfInit (i: init) : typ = - match i with - SingleInit e -> typeOf e - | CompoundInit (t, _) -> t - -and typeOfLval = function - Var vi, off -> typeOffset vi.vtype off - | Mem addr, off -> begin - match unrollType (typeOf addr) with - TPtr (t, _) -> typeOffset t off - | _ -> E.s (bug "typeOfLval: Mem on a non-pointer") - end - -and typeOffset basetyp = - let blendAttributes baseAttrs = - let (_, _, contageous) = - partitionAttributes ~default:(AttrName false) baseAttrs in - typeAddAttributes contageous - in - function - NoOffset -> basetyp - | Index (_, o) -> begin - match unrollType basetyp with - TArray (t, _, baseAttrs) -> - let elementType = typeOffset t o in - blendAttributes baseAttrs elementType - | t -> E.s (E.bug "typeOffset: Index on a non-array") - end - | Field (fi, o) -> - match unrollType basetyp with - TComp (_, baseAttrs) -> - let fieldType = typeOffset fi.ftype o in - blendAttributes baseAttrs fieldType - | _ -> E.s (bug "typeOffset: Field on a non-compound") - - -(** - ** - ** MACHINE DEPENDENT PART - ** - **) -exception SizeOfError of string * typ - - -(* Get the minimum aligment in bytes for a given type *) -let rec alignOf_int = function - | TInt((IChar|ISChar|IUChar), _) -> 1 - | TInt((IShort|IUShort), _) -> !theMachine.M.alignof_short - | TInt((IInt|IUInt), _) -> !theMachine.M.alignof_int - | TInt((ILong|IULong), _) -> !theMachine.M.alignof_long - | TInt((ILongLong|IULongLong), _) -> !theMachine.M.alignof_longlong - | TEnum _ -> !theMachine.M.alignof_enum - | TFloat(FFloat, _) -> !theMachine.M.alignof_float - | TFloat(FDouble, _) -> !theMachine.M.alignof_double - | TFloat(FLongDouble, _) -> !theMachine.M.alignof_longdouble - | TNamed (t, _) -> alignOf_int t.ttype - | TArray (t, _, _) -> alignOf_int t - | TPtr _ | TBuiltin_va_list _ -> !theMachine.M.alignof_ptr - - (* For composite types get the maximum alignment of any field inside *) - | TComp (c, _) -> - (* On GCC the zero-width fields do not contribute to the alignment. On - * MSVC only those zero-width that _do_ appear after other - * bitfields contribute to the alignment. So we drop those that - * do not occur after othe bitfields *) - let rec dropZeros (afterbitfield: bool) = function - | f :: rest when f.fbitfield = Some 0 && not afterbitfield -> - dropZeros afterbitfield rest - | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest - | [] -> [] - in - let fields = dropZeros false c.cfields in - List.fold_left - (fun sofar f -> - (* Bitfields with zero width do not contribute to the alignment in - * GCC *) - if not !msvcMode && f.fbitfield = Some 0 then sofar else - max sofar (alignOf_int f.ftype)) 1 fields - (* These are some error cases *) - | TFun _ when not !msvcMode -> !theMachine.M.alignof_fun - - | TFun _ as t -> raise (SizeOfError ("function", t)) - | TVoid _ as t -> raise (SizeOfError ("void", t)) - - -let bitsSizeOfInt (ik: ikind): int = - match ik with - | IChar | ISChar | IUChar -> 8 - | IInt | IUInt -> 8 * !theMachine.M.sizeof_int - | IShort | IUShort -> 8 * !theMachine.M.sizeof_short - | ILong | IULong -> 8 * !theMachine.M.sizeof_long - | ILongLong | IULongLong -> 8 * !theMachine.M.sizeof_longlong - -(* Represents an integer as for a given kind. - Returns a flag saying whether the value was changed - during truncation (because it was too large to fit in k). *) -let truncateInteger64 (k: ikind) (i: int64) : int64 * bool = - let nrBits = bitsSizeOfInt k in - let signed = isSigned k in - if nrBits = 64 then - i, false - else begin - let i1 = Int64.shift_left i (64 - nrBits) in - let i2 = - if signed then Int64.shift_right i1 (64 - nrBits) - else Int64.shift_right_logical i1 (64 - nrBits) - in - let truncated = - if i2 = i then false - else - (* Examine the bits that we chopped off. If they are all zero, then - * any difference between i2 and i is due to a simple sign-extension. - * e.g. casting the constant 0x80000000 to int makes it - * 0xffffffff80000000. - * Suppress the truncation warning in this case. *) - let chopped = Int64.shift_right_logical i (64 - nrBits) - in chopped <> Int64.zero - in - i2, truncated - end - -(* Construct an integer constant with possible truncation *) -let kinteger64 (k: ikind) (i: int64) : exp = - let i', truncated = truncateInteger64 k i in - if truncated then - ignore (warnOpt "Truncating integer %s to %s\n" - (Int64.format "0x%x" i) (Int64.format "0x%x" i')); - Const (CInt64(i', k, None)) - -(* Construct an integer of a given kind. *) -let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i) - - -type offsetAcc = - { oaFirstFree: int; (* The first free bit *) - oaLastFieldStart: int; (* Where the previous field started *) - oaLastFieldWidth: int; (* The width of the previous field. Might not - * be same as FirstFree - FieldStart because - * of internal padding *) - oaPrevBitPack: (int * ikind * int) option; (* If the previous fields - * were packed bitfields, - * the bit where packing - * has started, the ikind - * of the bitfield and the - * width of the ikind *) - } - - -(* GCC version *) -(* Does not use the sofar.oaPrevBitPack *) -let rec offsetOfFieldAcc_GCC (fi: fieldinfo) - (sofar: offsetAcc) : offsetAcc = - (* field type *) - let ftype = unrollType fi.ftype in - let ftypeAlign = 8 * alignOf_int ftype in - let ftypeBits = bitsSizeOf ftype in -(* - if fi.fcomp.cname = "comp2468" || - fi.fcomp.cname = "comp2469" || - fi.fcomp.cname = "comp2470" || - fi.fcomp.cname = "comp2471" || - fi.fcomp.cname = "comp2472" || - fi.fcomp.cname = "comp2473" || - fi.fcomp.cname = "comp2474" || - fi.fcomp.cname = "comp2475" || - fi.fcomp.cname = "comp2476" || - fi.fcomp.cname = "comp2477" || - fi.fcomp.cname = "comp2478" then - - ignore (E.log "offsetOfFieldAcc_GCC(%s of %s:%a%a,firstFree=%d,pack=%a)\n" - fi.fname fi.fcomp.cname - d_type ftype - insert - (match fi.fbitfield with - None -> nil - | Some wdthis -> dprintf ":%d" wdthis) - sofar.oaFirstFree - insert - (match sofar.oaPrevBitPack with - None -> text "None" - | Some (packstart, _, wdpack) -> - dprintf "Some(packstart=%d,wd=%d)" - packstart wdpack)); -*) - match ftype, fi.fbitfield with - (* A width of 0 means that we must end the current packing. It seems that - * GCC pads only up to the alignment boundary for the type of this field. - * *) - | _, Some 0 -> - let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in - { oaFirstFree = firstFree; - oaLastFieldStart = firstFree; - oaLastFieldWidth = 0; - oaPrevBitPack = None } - - (* A bitfield cannot span more alignment boundaries of its type than the - * type itself *) - | _, Some wdthis - when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign - - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign -> - let start = addTrailing sofar.oaFirstFree ftypeAlign in - { oaFirstFree = start + wdthis; - oaLastFieldStart = start; - oaLastFieldWidth = wdthis; - oaPrevBitPack = None } - - (* Try a simple method. Just put the field down *) - | _, Some wdthis -> - { oaFirstFree = sofar.oaFirstFree + wdthis; - oaLastFieldStart = sofar.oaFirstFree; - oaLastFieldWidth = wdthis; - oaPrevBitPack = None - } - - (* Non-bitfield *) - | _, None -> - (* Align this field *) - let newStart = addTrailing sofar.oaFirstFree ftypeAlign in - { oaFirstFree = newStart + ftypeBits; - oaLastFieldStart = newStart; - oaLastFieldWidth = ftypeBits; - oaPrevBitPack = None; - } - -(* MSVC version *) -and offsetOfFieldAcc_MSVC (fi: fieldinfo) - (sofar: offsetAcc) : offsetAcc = - (* field type *) - let ftype = unrollType fi.ftype in - let ftypeAlign = 8 * alignOf_int ftype in - let ftypeBits = bitsSizeOf ftype in -(* - ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n" - fi.fname fi.fcomp.cname - d_type ftype - insert - (match fi.fbitfield with - None -> nil - | Some wdthis -> dprintf ":%d" wdthis) - sofar.oaFirstFree - insert - (match sofar.oaPrevBitPack with - None -> text "None" - | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)" - prevpack wdpack)); -*) - match ftype, fi.fbitfield, sofar.oaPrevBitPack with - (* Ignore zero-width bitfields that come after non-bitfields *) - | TInt (ikthis, _), Some 0, None -> - let firstFree = sofar.oaFirstFree in - { oaFirstFree = firstFree; - oaLastFieldStart = firstFree; - oaLastFieldWidth = 0; - oaPrevBitPack = None } - - (* If we are in a bitpack and we see a bitfield for a type with the - * different width than the pack, then we finish the pack and retry *) - | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits -> - let firstFree = - if sofar.oaFirstFree = packstart then packstart else - packstart + wdpack - in - offsetOfFieldAcc_MSVC fi - { oaFirstFree = addTrailing firstFree ftypeAlign; - oaLastFieldStart = sofar.oaLastFieldStart; - oaLastFieldWidth = sofar.oaLastFieldWidth; - oaPrevBitPack = None } - - (* A width of 0 means that we must end the current packing. *) - | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) -> - let firstFree = - if sofar.oaFirstFree = packstart then packstart else - packstart + wdpack - in - let firstFree = addTrailing firstFree ftypeAlign in - { oaFirstFree = firstFree; - oaLastFieldStart = firstFree; - oaLastFieldWidth = 0; - oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) } - - (* Check for a bitfield that fits in the current pack after some other - * bitfields *) - | TInt(ikthis, _), Some wdthis, Some (packstart, ikprev, wdpack) - when packstart + wdpack >= sofar.oaFirstFree + wdthis -> - { oaFirstFree = sofar.oaFirstFree + wdthis; - oaLastFieldStart = sofar.oaFirstFree; - oaLastFieldWidth = wdthis; - oaPrevBitPack = sofar.oaPrevBitPack - } - - - | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and - * restart. *) - let firstFree = - if sofar.oaFirstFree = packstart then packstart else - packstart + wdpack - in - offsetOfFieldAcc_MSVC fi - { oaFirstFree = addTrailing firstFree ftypeAlign; - oaLastFieldStart = sofar.oaLastFieldStart; - oaLastFieldWidth = sofar.oaLastFieldWidth; - oaPrevBitPack = None } - - (* No active bitfield pack. But we are seeing a bitfield. *) - | TInt(ikthis, _), Some wdthis, None -> - let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in - { oaFirstFree = firstFree + wdthis; - oaLastFieldStart = firstFree; - oaLastFieldWidth = wdthis; - oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); } - - (* No active bitfield pack. Non-bitfield *) - | _, None, None -> - (* Align this field *) - let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in - { oaFirstFree = firstFree + ftypeBits; - oaLastFieldStart = firstFree; - oaLastFieldWidth = ftypeBits; - oaPrevBitPack = None; - } - - | _, Some _, None -> E.s (E.bug "offsetAcc") - - -and offsetOfFieldAcc ~(fi: fieldinfo) - ~(sofar: offsetAcc) : offsetAcc = - if !msvcMode then offsetOfFieldAcc_MSVC fi sofar - else offsetOfFieldAcc_GCC fi sofar - -(* The size of a type, in bits. If struct or array then trailing padding is - * added *) -and bitsSizeOf t = - if not !initCIL_called then - E.s (E.error "You did not call Cil.initCIL before using the CIL library"); - match t with - | TInt (ik,_) -> bitsSizeOfInt ik - | TFloat(FDouble, _) -> 8 * !theMachine.M.sizeof_double - | TFloat(FLongDouble, _) -> 8 * !theMachine.M.sizeof_longdouble - | TFloat _ -> 8 * !theMachine.M.sizeof_float - | TEnum _ -> 8 * !theMachine.M.sizeof_enum - | TPtr _ -> 8 * !theMachine.M.sizeof_ptr - | TBuiltin_va_list _ -> 8 * !theMachine.M.sizeof_ptr - | TNamed (t, _) -> bitsSizeOf t.ttype - | TComp (comp, _) when comp.cfields == [] -> begin - (* Empty structs are allowed in msvc mode *) - if not comp.cdefined && not !msvcMode then - raise (SizeOfError ("abstract type", t)) (*abstract type*) - else - 0 - end - - | TComp (comp, _) when comp.cstruct -> (* Struct *) - (* Go and get the last offset *) - let startAcc = - { oaFirstFree = 0; - oaLastFieldStart = 0; - oaLastFieldWidth = 0; - oaPrevBitPack = None; - } in - let lastoff = - List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc) - startAcc comp.cfields - in - if !msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then - (* On MSVC if we have just a zero-width bitfields then the length - * is 32 and is not padded *) - 32 - else - addTrailing lastoff.oaFirstFree (8 * alignOf_int t) - - | TComp (comp, _) -> (* when not comp.cstruct *) - (* Get the maximum of all fields *) - let startAcc = - { oaFirstFree = 0; - oaLastFieldStart = 0; - oaLastFieldWidth = 0; - oaPrevBitPack = None; - } in - let max = - List.fold_left (fun acc fi -> - let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in - if lastoff.oaFirstFree > acc then - lastoff.oaFirstFree else acc) 0 comp.cfields in - (* Add trailing by simulating adding an extra field *) - addTrailing max (8 * alignOf_int t) - - | TArray(t, Some len, _) -> begin - match constFold true len with - Const(CInt64(l,_,_)) -> - addTrailing ((bitsSizeOf t) * (Int64.to_int l)) (8 * alignOf_int t) - | _ -> raise (SizeOfError ("array non-constant length", t)) - end - - - | TVoid _ -> 8 * !theMachine.M.sizeof_void - | TFun _ when not !msvcMode -> (* On GCC the size of a function is defined *) - 8 * !theMachine.M.sizeof_fun - - | TArray (_, None, _) -> (* it seems that on GCC the size of such an - * array is 0 *) - 0 - - | TFun _ -> raise (SizeOfError ("function", t)) - - -and addTrailing nrbits roundto = - (nrbits + roundto - 1) land (lnot (roundto - 1)) - -and sizeOf t = - try - integer ((bitsSizeOf t) lsr 3) - with SizeOfError _ -> SizeOf(t) - - -and bitsOffset (baset: typ) (off: offset) : int * int = - let rec loopOff (baset: typ) (width: int) (start: int) = function - NoOffset -> start, width - | Index(e, off) -> begin - let ei = - match isInteger e with - Some i64 -> Int64.to_int i64 - | None -> raise (SizeOfError ("index not constant", baset)) - in - let bt = - match unrollType baset with - TArray(bt, _, _) -> bt - | _ -> E.s (E.bug "bitsOffset: Index on a non-array") - in - let bitsbt = bitsSizeOf bt in - loopOff bt bitsbt (start + ei * bitsbt) off - end - | Field(f, off) when not f.fcomp.cstruct -> - (* All union fields start at offset 0 *) - loopOff f.ftype (bitsSizeOf f.ftype) start off - - | Field(f, off) -> - (* Construct a list of fields preceeding and including this one *) - let prevflds = - let rec loop = function - [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n" - f.fname f.fcomp.cname) - | fi' :: _ when fi' == f -> [fi'] - | fi' :: rest -> fi' :: loop rest - in - loop f.fcomp.cfields - in - let lastoff = - List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc) - { oaFirstFree = 0; (* Start at 0 because each struct is done - * separately *) - oaLastFieldStart = 0; - oaLastFieldWidth = 0; - oaPrevBitPack = None } prevflds - in - (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n" - f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *) - loopOff f.ftype lastoff.oaLastFieldWidth - (start + lastoff.oaLastFieldStart) off - in - loopOff baset (bitsSizeOf baset) 0 off - - - - -(*** Constant folding. If machdep is true then fold even sizeof operations ***) -and constFold (machdep: bool) (e: exp) : exp = - match e with - BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres - | UnOp(unop, e1, tres) -> begin - try - let tk = - match unrollType tres with - TInt(ik, _) -> ik - | TEnum _ -> IInt - | _ -> raise Not_found (* probably a float *) - in - match constFold machdep e1 with - Const(CInt64(i,ik,_)) -> begin - match unop with - Neg -> kinteger64 tk (Int64.neg i) - | BNot -> kinteger64 tk (Int64.lognot i) - | LNot -> if i = Int64.zero then one else zero - end - | e1c -> UnOp(unop, e1c, tres) - with Not_found -> e - end - (* Characters are integers *) - | Const(CChr c) -> Const(charConstToInt c) - | Const(CEnum (v, _, _)) -> constFold machdep v - | SizeOf t when machdep -> begin - try - let bs = bitsSizeOf t in - kinteger !kindOfSizeOf (bs / 8) - with SizeOfError _ -> e - end - | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e)) - | SizeOfStr s when machdep -> kinteger !kindOfSizeOf (1 + String.length s) - | AlignOf t when machdep -> kinteger !kindOfSizeOf (alignOf_int t) - | AlignOfE e when machdep -> begin - (* The alignmetn of an expression is not always the alignment of its - * type. I know that for strings this is not true *) - match e with - Const (CStr _) when not !msvcMode -> - kinteger !kindOfSizeOf !theMachine.M.alignof_str - (* For an array, it is the alignment of the array ! *) - | _ -> constFold machdep (AlignOf (typeOf e)) - end - - | CastE(it, - AddrOf (Mem (CastE(TPtr(bt, _), z)), off)) - when machdep && isZero z -> begin - try - let start, width = bitsOffset bt off in - if start mod 8 <> 0 then - E.s (error "Using offset of bitfield\n"); - constFold machdep (CastE(it, (integer (start / 8)))) - with SizeOfError _ -> e - end - - - | CastE (t, e) -> begin - match constFold machdep e, unrollType t with - (* Might truncate silently *) - Const(CInt64(i,k,_)), TInt(nk,_) -> - let i', _ = truncateInteger64 nk i in - Const(CInt64(i', nk, None)) - | e', _ -> CastE (t, e') - end - - | _ -> e - -and constFoldBinOp (machdep: bool) bop e1 e2 tres = - let e1' = constFold machdep e1 in - let e2' = constFold machdep e2 in - if isIntegralType tres then begin - let newe = - let rec mkInt = function - Const(CChr c) -> Const(charConstToInt c) - | Const(CEnum (v, s, ei)) -> mkInt v - | CastE(TInt (ik, ta), e) -> begin - match mkInt e with - Const(CInt64(i, _, _)) -> - let i', _ = truncateInteger64 ik i in - Const(CInt64(i', ik, None)) - - | e' -> CastE(TInt(ik, ta), e') - end - | e -> e - in - let tk = - match unrollType tres with - TInt(ik, _) -> ik - | TEnum _ -> IInt - | _ -> E.s (bug "constFoldBinOp") - in - (* See if the result is unsigned *) - let isunsigned typ = not (isSigned typ) in - let ge (unsigned: bool) (i1: int64) (i2: int64) : bool = - if unsigned then - let l1 = Int64.shift_right_logical i1 1 in - let l2 = Int64.shift_right_logical i2 1 in (* Both positive now *) - (l1 > l2) || (l1 = l2 && - Int64.logand i1 Int64.one >= Int64.logand i2 Int64.one) - else i1 >= i2 - in - let shiftInBounds i2 = - (* We only try to fold shifts if the second arg is positive and - less than 64. Otherwise, the semantics are processor-dependent, - so let the compiler sort it out. *) - i2 >= Int64.zero && i2 < (Int64.of_int 64) - in - (* Assume that the necessary promotions have been done *) - match bop, mkInt e1', mkInt e2' with - | PlusA, Const(CInt64(z,_,_)), e2'' when z = Int64.zero -> e2'' - | PlusA, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' - | PlusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' - | IndexPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' - | MinusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' - | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - kinteger64 tk (Int64.add i1 i2) - | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - kinteger64 tk (Int64.sub i1 i2) - | Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - kinteger64 tk (Int64.mul i1 i2) - | Mult, Const(CInt64(0L,_,_)), _ -> zero - | Mult, Const(CInt64(1L,_,_)), e2'' -> e2'' - | Mult, _, Const(CInt64(0L,_,_)) -> zero - | Mult, e1'', Const(CInt64(1L,_,_)) -> e1'' - | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin - try kinteger64 tk (Int64.div i1 i2) - with Division_by_zero -> BinOp(bop, e1', e2', tres) - end - | Div, e1'', Const(CInt64(1L,_,_)) -> e1'' - - | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin - try kinteger64 tk (Int64.rem i1 i2) - with Division_by_zero -> BinOp(bop, e1', e2', tres) - end - | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - kinteger64 tk (Int64.logand i1 i2) - | BAnd, Const(CInt64(0L,_,_)), _ -> zero - | BAnd, _, Const(CInt64(0L,_,_)) -> zero - | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - kinteger64 tk (Int64.logor i1 i2) - | BOr, _, _ when isZero e1' -> e2' - | BOr, _, _ when isZero e2' -> e1' - | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - kinteger64 tk (Int64.logxor i1 i2) - - | Shiftlt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> - kinteger64 tk (Int64.shift_left i1 (Int64.to_int i2)) - | Shiftlt, Const(CInt64(0L,_,_)), _ -> zero - | Shiftlt, e1'', Const(CInt64(0L,_,_)) -> e1'' - - | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> - if isunsigned ik1 then - kinteger64 tk (Int64.shift_right_logical i1 (Int64.to_int i2)) - else - kinteger64 tk (Int64.shift_right i1 (Int64.to_int i2)) - | Shiftrt, Const(CInt64(0L,_,_)), _ -> zero - | Shiftrt, e1'', Const(CInt64(0L,_,_)) -> e1'' - - | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - integer (if i1 = i2 then 1 else 0) - | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - integer (if i1 <> i2 then 1 else 0) - | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - integer (if ge (isunsigned ik1) i2 i1 then 1 else 0) - - | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - integer (if ge (isunsigned ik1) i1 i2 then 1 else 0) - - | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - integer (if i1 <> i2 && ge (isunsigned ik1) i2 i1 then 1 else 0) - - | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> - integer (if i1 <> i2 && ge (isunsigned ik1) i1 i2 then 1 else 0) - | LAnd, _, _ when isZero e1' || isZero e2' -> zero - | LOr, _, _ when isZero e1' -> e2' - | LOr, _, _ when isZero e2' -> e1' - | _ -> BinOp(bop, e1', e2', tres) - in - if debugConstFold then - ignore (E.log "Folded %a to %a\n" - (!pd_exp) (BinOp(bop, e1', e2', tres)) (!pd_exp) newe); - newe - end else - BinOp(bop, e1', e2', tres) - - - -let parseInt (str: string) : exp = - let hasSuffix str = - let l = String.length str in - fun s -> - let ls = String.length s in - l >= ls && s = String.uppercase (String.sub str (l - ls) ls) - in - let l = String.length str in - (* See if it is octal or hex *) - let octalhex = (l >= 1 && String.get str 0 = '0') in - (* The length of the suffix and a list of possible kinds. See ISO - * 6.4.4.1 *) - let hasSuffix = hasSuffix str in - let suffixlen, kinds = - if hasSuffix "ULL" || hasSuffix "LLU" then - 3, [IULongLong] - else if hasSuffix "LL" then - 2, if octalhex then [ILongLong; IULongLong] else [ILongLong] - else if hasSuffix "UL" || hasSuffix "LU" then - 2, [IULong; IULongLong] - else if hasSuffix "L" then - 1, if octalhex then [ILong; IULong; ILongLong; IULongLong] - else [ILong; ILongLong] - else if hasSuffix "U" then - 1, [IUInt; IULong; IULongLong] - else if (!msvcMode && hasSuffix "UI64") then - 4, [IULongLong] - else if (!msvcMode && hasSuffix "I64") then - 3, [ILongLong] - else - 0, if octalhex || true (* !!! This is against the ISO but it - * is what GCC and MSVC do !!! *) - then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong] - else [IInt; ILong; IUInt; ILongLong] - in - (* Convert to integer. To prevent overflow we do the arithmetic - * on Int64 and we take care of overflow. We work only with - * positive integers since the lexer takes care of the sign *) - let rec toInt (base: int64) (acc: int64) (idx: int) : int64 = - let doAcc (what: int) = - let acc' = - Int64.add (Int64.mul base acc) (Int64.of_int what) in - if acc < Int64.zero || (* We clearly overflow since base >= 2 - * *) - (acc' > Int64.zero && acc' < acc) then - E.s (unimp "Cannot represent on 64 bits the integer %s\n" - str) - else - toInt base acc' (idx + 1) - in - if idx >= l - suffixlen then begin - acc - end else - let ch = String.get str idx in - if ch >= '0' && ch <= '9' then - doAcc (Char.code ch - Char.code '0') - else if ch >= 'a' && ch <= 'f' then - doAcc (10 + Char.code ch - Char.code 'a') - else if ch >= 'A' && ch <= 'F' then - doAcc (10 + Char.code ch - Char.code 'A') - else - E.s (bug "Invalid integer constant: %s (char %c at idx=%d)" - str ch idx) - in - try - let i = - if octalhex then - if l >= 2 && - (let c = String.get str 1 in c = 'x' || c = 'X') then - toInt (Int64.of_int 16) Int64.zero 2 - else - toInt (Int64.of_int 8) Int64.zero 1 - else - toInt (Int64.of_int 10) Int64.zero 0 - in - (* Construct an integer of the first kinds that fits. i must be - * POSITIVE *) - let res = - let rec loop = function - | ((IInt | ILong) as k) :: _ - when i < Int64.shift_left (Int64.of_int 1) 31 -> - kinteger64 k i - | ((IUInt | IULong) as k) :: _ - when i < Int64.shift_left (Int64.of_int 1) 32 - -> kinteger64 k i - | (ILongLong as k) :: _ - when i <= Int64.sub (Int64.shift_left - (Int64.of_int 1) 63) - (Int64.of_int 1) - -> - kinteger64 k i - | (IULongLong as k) :: _ -> kinteger64 k i - | _ :: rest -> loop rest - | [] -> E.s (E.unimp "Cannot represent the integer %s\n" - (Int64.to_string i)) - in - loop kinds - in - res - with e -> begin - ignore (E.log "int_of_string %s (%s)\n" str - (Printexc.to_string e)); - zero - end - - - -let d_unop () u = - match u with - Neg -> text "-" - | BNot -> text "~" - | LNot -> text "!" - -let d_binop () b = - match b with - PlusA | PlusPI | IndexPI -> text "+" - | MinusA | MinusPP | MinusPI -> text "-" - | Mult -> text "*" - | Div -> text "/" - | Mod -> text "%" - | Shiftlt -> text "<<" - | Shiftrt -> text ">>" - | Lt -> text "<" - | Gt -> text ">" - | Le -> text "<=" - | Ge -> text ">=" - | Eq -> text "==" - | Ne -> text "!=" - | BAnd -> text "&" - | BXor -> text "^" - | BOr -> text "|" - | LAnd -> text "&&" - | LOr -> text "||" - -let invalidStmt = mkStmt (Instr []) - -(** Construct a hash with the builtins *) -let gccBuiltins : (string, typ * typ list * bool) H.t = - let h = H.create 17 in - (* See if we have builtin_va_list *) - let hasbva = M.gccHas__builtin_va_list in - let ulongLongType = TInt(IULongLong, []) in - let floatType = TFloat(FFloat, []) in - let longDoubleType = TFloat (FLongDouble, []) in - let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], []) in - let sizeType = uintType in - - H.add h "__builtin___fprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *); - H.add h "__builtin___memcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false); - H.add h "__builtin___memmove_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false); - H.add h "__builtin___mempcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false); - H.add h "__builtin___memset_chk" (voidPtrType, [ voidPtrType; intType; sizeType; sizeType ], false); - H.add h "__builtin___printf_chk" (intType, [ intType; charConstPtrType ], true); - H.add h "__builtin___snprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType ], true); - H.add h "__builtin___sprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType ], true); - H.add h "__builtin___stpcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); - H.add h "__builtin___strcat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); - H.add h "__builtin___strcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); - H.add h "__builtin___strncat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false); - H.add h "__builtin___strncpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false); - H.add h "__builtin___vfprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ], false) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *); - H.add h "__builtin___vprintf_chk" (intType, [ intType; charConstPtrType; TBuiltin_va_list [] ], false); - H.add h "__builtin___vsnprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false); - H.add h "__builtin___vsprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false); - - H.add h "__builtin_acos" (doubleType, [ doubleType ], false); - H.add h "__builtin_acosf" (floatType, [ floatType ], false); - H.add h "__builtin_acosl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_alloca" (voidPtrType, [ uintType ], false); - - H.add h "__builtin_asin" (doubleType, [ doubleType ], false); - H.add h "__builtin_asinf" (floatType, [ floatType ], false); - H.add h "__builtin_asinl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_atan" (doubleType, [ doubleType ], false); - H.add h "__builtin_atanf" (floatType, [ floatType ], false); - H.add h "__builtin_atanl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_atan2" (doubleType, [ doubleType; doubleType ], false); - H.add h "__builtin_atan2f" (floatType, [ floatType; floatType ], false); - H.add h "__builtin_atan2l" (longDoubleType, [ longDoubleType; - longDoubleType ], false); - - H.add h "__builtin_ceil" (doubleType, [ doubleType ], false); - H.add h "__builtin_ceilf" (floatType, [ floatType ], false); - H.add h "__builtin_ceill" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_cos" (doubleType, [ doubleType ], false); - H.add h "__builtin_cosf" (floatType, [ floatType ], false); - H.add h "__builtin_cosl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_cosh" (doubleType, [ doubleType ], false); - H.add h "__builtin_coshf" (floatType, [ floatType ], false); - H.add h "__builtin_coshl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_clz" (intType, [ uintType ], false); - H.add h "__builtin_clzl" (intType, [ ulongType ], false); - H.add h "__builtin_clzll" (intType, [ ulongLongType ], false); - H.add h "__builtin_constant_p" (intType, [ intType ], false); - H.add h "__builtin_ctz" (intType, [ uintType ], false); - H.add h "__builtin_ctzl" (intType, [ ulongType ], false); - H.add h "__builtin_ctzll" (intType, [ ulongLongType ], false); - - H.add h "__builtin_exp" (doubleType, [ doubleType ], false); - H.add h "__builtin_expf" (floatType, [ floatType ], false); - H.add h "__builtin_expl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_expect" (longType, [ longType; longType ], false); - - H.add h "__builtin_fabs" (doubleType, [ doubleType ], false); - H.add h "__builtin_fabsf" (floatType, [ floatType ], false); - H.add h "__builtin_fabsl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_ffs" (intType, [ uintType ], false); - H.add h "__builtin_ffsl" (intType, [ ulongType ], false); - H.add h "__builtin_ffsll" (intType, [ ulongLongType ], false); - H.add h "__builtin_frame_address" (voidPtrType, [ uintType ], false); - - H.add h "__builtin_floor" (doubleType, [ doubleType ], false); - H.add h "__builtin_floorf" (floatType, [ floatType ], false); - H.add h "__builtin_floorl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_huge_val" (doubleType, [], false); - H.add h "__builtin_huge_valf" (floatType, [], false); - H.add h "__builtin_huge_vall" (longDoubleType, [], false); - H.add h "__builtin_inf" (doubleType, [], false); - H.add h "__builtin_inff" (floatType, [], false); - H.add h "__builtin_infl" (longDoubleType, [], false); - H.add h "__builtin_memcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; uintType ], false); - H.add h "__builtin_mempcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false); - - H.add h "__builtin_fmod" (doubleType, [ doubleType ], false); - H.add h "__builtin_fmodf" (floatType, [ floatType ], false); - H.add h "__builtin_fmodl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_frexp" (doubleType, [ doubleType; intPtrType ], false); - H.add h "__builtin_frexpf" (floatType, [ floatType; intPtrType ], false); - H.add h "__builtin_frexpl" (longDoubleType, [ longDoubleType; - intPtrType ], false); - - H.add h "__builtin_ldexp" (doubleType, [ doubleType; intType ], false); - H.add h "__builtin_ldexpf" (floatType, [ floatType; intType ], false); - H.add h "__builtin_ldexpl" (longDoubleType, [ longDoubleType; - intType ], false); - - H.add h "__builtin_log" (doubleType, [ doubleType ], false); - H.add h "__builtin_logf" (floatType, [ floatType ], false); - H.add h "__builtin_logl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_log10" (doubleType, [ doubleType ], false); - H.add h "__builtin_log10f" (floatType, [ floatType ], false); - H.add h "__builtin_log10l" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_modff" (floatType, [ floatType; - TPtr(floatType,[]) ], false); - H.add h "__builtin_modfl" (longDoubleType, [ longDoubleType; - TPtr(longDoubleType, []) ], - false); - - H.add h "__builtin_nan" (doubleType, [ charConstPtrType ], false); - H.add h "__builtin_nanf" (floatType, [ charConstPtrType ], false); - H.add h "__builtin_nanl" (longDoubleType, [ charConstPtrType ], false); - H.add h "__builtin_nans" (doubleType, [ charConstPtrType ], false); - H.add h "__builtin_nansf" (floatType, [ charConstPtrType ], false); - H.add h "__builtin_nansl" (longDoubleType, [ charConstPtrType ], false); - H.add h "__builtin_next_arg" ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false) (* When we parse builtin_next_arg we drop the second argument *); - H.add h "__builtin_object_size" (sizeType, [ voidPtrType; intType ], false); - - H.add h "__builtin_parity" (intType, [ uintType ], false); - H.add h "__builtin_parityl" (intType, [ ulongType ], false); - H.add h "__builtin_parityll" (intType, [ ulongLongType ], false); - - H.add h "__builtin_popcount" (intType, [ uintType ], false); - H.add h "__builtin_popcountl" (intType, [ ulongType ], false); - H.add h "__builtin_popcountll" (intType, [ ulongLongType ], false); - - H.add h "__builtin_powi" (doubleType, [ doubleType; intType ], false); - H.add h "__builtin_powif" (floatType, [ floatType; intType ], false); - H.add h "__builtin_powil" (longDoubleType, [ longDoubleType; intType ], false); - H.add h "__builtin_prefetch" (voidType, [ voidConstPtrType ], true); - H.add h "__builtin_return" (voidType, [ voidConstPtrType ], false); - H.add h "__builtin_return_address" (voidPtrType, [ uintType ], false); - - H.add h "__builtin_sin" (doubleType, [ doubleType ], false); - H.add h "__builtin_sinf" (floatType, [ floatType ], false); - H.add h "__builtin_sinl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_sinh" (doubleType, [ doubleType ], false); - H.add h "__builtin_sinhf" (floatType, [ floatType ], false); - H.add h "__builtin_sinhl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_sqrt" (doubleType, [ doubleType ], false); - H.add h "__builtin_sqrtf" (floatType, [ floatType ], false); - H.add h "__builtin_sqrtl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_stpcpy" (charPtrType, [ charPtrType; charConstPtrType ], false); - H.add h "__builtin_strchr" (charPtrType, [ charPtrType; charType ], false); - H.add h "__builtin_strcmp" (intType, [ charConstPtrType; charConstPtrType ], false); - H.add h "__builtin_strcpy" (charPtrType, [ charPtrType; charConstPtrType ], false); - H.add h "__builtin_strcspn" (uintType, [ charConstPtrType; charConstPtrType ], false); - H.add h "__builtin_strncat" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); - H.add h "__builtin_strncmp" (intType, [ charConstPtrType; charConstPtrType; sizeType ], false); - H.add h "__builtin_strncpy" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); - H.add h "__builtin_strspn" (intType, [ charConstPtrType; charConstPtrType ], false); - H.add h "__builtin_strpbrk" (charPtrType, [ charConstPtrType; charConstPtrType ], false); - (* When we parse builtin_types_compatible_p, we change its interface *) - H.add h "__builtin_types_compatible_p" - (intType, [ uintType; (* Sizeof the type *) - uintType (* Sizeof the type *) ], - false); - H.add h "__builtin_tan" (doubleType, [ doubleType ], false); - H.add h "__builtin_tanf" (floatType, [ floatType ], false); - H.add h "__builtin_tanl" (longDoubleType, [ longDoubleType ], false); - - H.add h "__builtin_tanh" (doubleType, [ doubleType ], false); - H.add h "__builtin_tanhf" (floatType, [ floatType ], false); - H.add h "__builtin_tanhl" (longDoubleType, [ longDoubleType ], false); - - - if hasbva then begin - H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false); - H.add h "__builtin_varargs_start" - (voidType, [ TBuiltin_va_list [] ], false); - H.add h "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false); - (* When we parse builtin_stdarg_start, we drop the second argument *) - H.add h "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ], - false); - (* When we parse builtin_va_arg we change its interface *) - H.add h "__builtin_va_arg" (voidType, [ TBuiltin_va_list []; - uintType; (* Sizeof the type *) - voidPtrType; (* Ptr to res *) ], - false); - H.add h "__builtin_va_copy" (voidType, [ TBuiltin_va_list []; - TBuiltin_va_list [] ], - false); - end; - h - -(** Construct a hash with the builtins *) -let msvcBuiltins : (string, typ * typ list * bool) H.t = - (* These are empty for now but can be added to depending on the application*) - let h = H.create 17 in - (** Take a number of wide string literals *) - H.add h "__annotation" (voidType, [ ], true); - h - - - -let pTypeSig : (typ -> typsig) ref = - ref (fun _ -> E.s (E.bug "pTypeSig not initialized")) - - -(** A printer interface for CIL trees. Create instantiations of - * this type by specializing the class {!Cil.defaultCilPrinter}. *) -class type cilPrinter = object - method pVDecl: unit -> varinfo -> doc - (** Invoked for each variable declaration. Note that variable - * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] - * in formals of function types, and the formals and locals for function - * definitions. *) - - method pVar: varinfo -> doc - (** Invoked on each variable use. *) - - method pLval: unit -> lval -> doc - (** Invoked on each lvalue occurence *) - - method pOffset: doc -> offset -> doc - (** Invoked on each offset occurence. The second argument is the base. *) - - method pInstr: unit -> instr -> doc - (** Invoked on each instruction occurrence. *) - - method pStmt: unit -> stmt -> doc - (** Control-flow statement. This is used by - * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *) - - method dStmt: out_channel -> int -> stmt -> unit - (** Dump a control-flow statement to a file with a given indentation. This is used by - * {!Cil.dumpGlobal}. *) - - method dBlock: out_channel -> int -> block -> unit - (** Dump a control-flow block to a file with a given indentation. This is - * used by {!Cil.dumpGlobal}. *) - - method pBlock: unit -> block -> Pretty.doc - (** Print a block. *) - - method pGlobal: unit -> global -> doc - (** Global (vars, types, etc.). This can be slow and is used only by - * {!Cil.printGlobal} but by {!Cil.dumpGlobal} for everything else except - * [GVar] and [GFun]. *) - - method dGlobal: out_channel -> global -> unit - (** Dump a global to a file. This is used by {!Cil.dumpGlobal}. *) - - method pFieldDecl: unit -> fieldinfo -> doc - (** A field declaration *) - - method pType: doc option -> unit -> typ -> doc - (* Use of some type in some declaration. The first argument is used to print - * the declared element, or is None if we are just printing a type with no - * name being decalred. Note that for structure/union and enumeration types - * the definition of the composite type is not visited. Use [vglob] to - * visit it. *) - - method pAttr: attribute -> doc * bool - (** Attribute. Also return an indication whether this attribute must be - * printed inside the __attribute__ list or not. *) - - method pAttrParam: unit -> attrparam -> doc - (** Attribute paramter *) - - method pAttrs: unit -> attributes -> doc - (** Attribute lists *) - - method pLabel: unit -> label -> doc - (** Label *) - - method pLineDirective: ?forcefile:bool -> location -> Pretty.doc - (** Print a line-number. This is assumed to come always on an empty line. - * If the forcefile argument is present and is true then the file name - * will be printed always. Otherwise the file name is printed only if it - * is different from the last time time this function is called. The last - * file name is stored in a private field inside the cilPrinter object. *) - - method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc - (** Print a statement kind. The code to be printed is given in the - * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument - * records the statement which follows the one being printed; - * {!Cil.defaultCilPrinterClass} uses this information to prettify - * statement printing in certain special cases. *) - - method pExp: unit -> exp -> doc - (** Print expressions *) - - method pInit: unit -> init -> doc - (** Print initializers. This can be slow and is used by - * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) - - method dInit: out_channel -> int -> init -> unit - (** Dump a global to a file with a given indentation. This is used by - * {!Cil.dumpGlobal}. *) -end - - -class defaultCilPrinterClass : cilPrinter = object (self) - val mutable currentFormals : varinfo list = [] - method private getLastNamedArgument (s: string) : exp = - match List.rev currentFormals with - f :: _ -> Lval (var f) - | [] -> - E.s (warn "Cannot find the last named argument when priting call to %s\n" s) - - (*** VARIABLES ***) - (* variable use *) - method pVar (v:varinfo) = text v.vname - - (* variable declaration *) - method pVDecl () (v:varinfo) = - let stom, rest = separateStorageModifiers v.vattr in - (* First the storage modifiers *) - text (if v.vinline then "__inline " else "") - ++ d_storage () v.vstorage - ++ (self#pAttrs () stom) - ++ (self#pType (Some (text v.vname)) () v.vtype) - ++ text " " - ++ self#pAttrs () rest - - (*** L-VALUES ***) - method pLval () (lv:lval) = (* lval (base is 1st field) *) - match lv with - Var vi, o -> self#pOffset (self#pVar vi) o - | Mem e, Field(fi, o) -> - self#pOffset - ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o - | Mem e, o -> - self#pOffset - (text "(*" ++ self#pExpPrec derefStarLevel () e ++ text ")") o - - (** Offsets **) - method pOffset (base: doc) = function - | NoOffset -> base - | Field (fi, o) -> - self#pOffset (base ++ text "." ++ text fi.fname) o - | Index (e, o) -> - self#pOffset (base ++ text "[" ++ self#pExp () e ++ text "]") o - - method private pLvalPrec (contextprec: int) () lv = - if getParenthLevel (Lval(lv)) >= contextprec then - text "(" ++ self#pLval () lv ++ text ")" - else - self#pLval () lv - - (*** EXPRESSIONS ***) - method pExp () (e: exp) : doc = - let level = getParenthLevel e in - match e with - Const(c) -> d_const () c - | Lval(l) -> self#pLval () l - | UnOp(u,e1,_) -> - (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1) - - | BinOp(b,e1,e2,_) -> - align - ++ (self#pExpPrec level () e1) - ++ chr ' ' - ++ (d_binop () b) - ++ chr ' ' - ++ (self#pExpPrec level () e2) - ++ unalign - - | CastE(t,e) -> - text "(" - ++ self#pType None () t - ++ text ")" - ++ self#pExpPrec level () e - - | SizeOf (t) -> - text "sizeof(" ++ self#pType None () t ++ chr ')' - | SizeOfE (e) -> - text "sizeof(" ++ self#pExp () e ++ chr ')' - - | SizeOfStr s -> - text "sizeof(" ++ d_const () (CStr s) ++ chr ')' - - | AlignOf (t) -> - text "__alignof__(" ++ self#pType None () t ++ chr ')' - | AlignOfE (e) -> - text "__alignof__(" ++ self#pExp () e ++ chr ')' - | AddrOf(lv) -> - text "& " ++ (self#pLvalPrec addrOfLevel () lv) - - | StartOf(lv) -> self#pLval () lv - - method private pExpPrec (contextprec: int) () (e: exp) = - let thisLevel = getParenthLevel e in - let needParens = - if thisLevel >= contextprec then - true - else if contextprec == bitwiseLevel then - (* quiet down some GCC warnings *) - thisLevel == additiveLevel || thisLevel == comparativeLevel - else - false - in - if needParens then - chr '(' ++ self#pExp () e ++ chr ')' - else - self#pExp () e - - method pInit () = function - SingleInit e -> self#pExp () e - | CompoundInit (t, initl) -> - (* We do not print the type of the Compound *) -(* - let dinit e = d_init () e in - dprintf "{@[%a@]}" - (docList ~sep:(chr ',' ++ break) dinit) initl -*) - let printDesignator = - if not !msvcMode then begin - (* Print only for union when we do not initialize the first field *) - match unrollType t, initl with - TComp(ci, _), [(Field(f, NoOffset), _)] -> - if not (ci.cstruct) && ci.cfields != [] && - (List.hd ci.cfields) != f then - true - else - false - | _ -> false - end else - false - in - let d_oneInit = function - Field(f, NoOffset), i -> - (if printDesignator then - text ("." ^ f.fname ^ " = ") - else nil) ++ self#pInit () i - | Index(e, NoOffset), i -> - (if printDesignator then - text "[" ++ self#pExp () e ++ text "] = " else nil) ++ - self#pInit () i - | _ -> E.s (unimp "Trying to print malformed initializer") - in - chr '{' ++ (align - ++ ((docList ~sep:(chr ',' ++ break) d_oneInit) () initl) - ++ unalign) - ++ chr '}' -(* - | ArrayInit (_, _, il) -> - chr '{' ++ (align - ++ ((docList (chr ',' ++ break) (self#pInit ())) () il) - ++ unalign) - ++ chr '}' -*) - (* dump initializers to a file. *) - method dInit (out: out_channel) (ind: int) (i: init) = - (* Dump an array *) - let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) = - let onALine = (* How many elements on a line *) - match unrollType bt with TComp _ | TArray _ -> 1 | _ -> 4 - in - let rec outputElements (isfirst: bool) (room_on_line: int) = function - [] -> output_string out "}" - | (i: 'a) :: rest -> - if not isfirst then output_string out ", "; - let new_room_on_line = - if room_on_line == 0 then begin - output_string out "\n"; output_string out (String.make ind ' '); - onALine - 1 - end else - room_on_line - 1 - in - self#dInit out (ind + 2) (getelem i); - outputElements false new_room_on_line rest - in - output_string out "{ "; - outputElements true onALine il - in - match i with - SingleInit e -> - fprint out !lineLength (indent ind (self#pExp () e)) - | CompoundInit (t, initl) -> begin - match unrollType t with - TArray(bt, _, _) -> - dumpArray bt initl (fun (_, i) -> i) - | _ -> - (* Now a structure or a union *) - fprint out !lineLength (indent ind (self#pInit () i)) - end -(* - | ArrayInit (bt, len, initl) -> begin - (* If the base type does not contain structs then use the pInit - match unrollType bt with - TComp _ | TArray _ -> - dumpArray bt initl (fun x -> x) - | _ -> *) - fprint out !lineLength (indent ind (self#pInit () i)) - end -*) - - (** What terminator to print after an instruction. sometimes we want to - * print sequences of instructions separated by comma *) - val mutable printInstrTerminator = ";" - - (*** INSTRUCTIONS ****) - method pInstr () (i:instr) = (* imperative instruction *) - match i with - | Set(lv,e,l) -> begin - (* Be nice to some special cases *) - match e with - BinOp((PlusA|PlusPI|IndexPI),Lval(lv'), Const(CInt64(one,_,_)),_) - when Util.equals lv lv' && one = Int64.one && not !printCilAsIs -> - self#pLineDirective l - ++ self#pLval () lv - ++ text (" ++" ^ printInstrTerminator) - - | BinOp((MinusA|MinusPI),Lval(lv'), - Const(CInt64(one,_,_)), _) - when Util.equals lv lv' && one = Int64.one && not !printCilAsIs -> - self#pLineDirective l - ++ self#pLval () lv - ++ text (" --" ^ printInstrTerminator) - - | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_) - when Util.equals lv lv' && mone = Int64.minus_one - && not !printCilAsIs -> - self#pLineDirective l - ++ self#pLval () lv - ++ text (" --" ^ printInstrTerminator) - - | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor| - Mult|Div|Mod|Shiftlt|Shiftrt) as bop, - Lval(lv'),e,_) when Util.equals lv lv' -> - self#pLineDirective l - ++ self#pLval () lv - ++ text " " ++ d_binop () bop - ++ text "= " - ++ self#pExp () e - ++ text printInstrTerminator - - | _ -> - self#pLineDirective l - ++ self#pLval () lv - ++ text " = " - ++ self#pExp () e - ++ text printInstrTerminator - - end - (* In cabs2cil we have turned the call to builtin_va_arg into a - * three-argument call: the last argument is the address of the - * destination *) - | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l) - when vi.vname = "__builtin_va_arg" && not !printCilAsIs -> - let destlv = match stripCasts adest with - AddrOf destlv -> destlv - | _ -> E.s (E.error "Encountered unexpected call to %s\n" vi.vname) - in - self#pLineDirective l - ++ self#pLval () destlv ++ text " = " - - (* Now the function name *) - ++ text "__builtin_va_arg" - ++ text "(" ++ (align - (* Now the arguments *) - ++ self#pExp () dest - ++ chr ',' ++ break - ++ self#pType None () t - ++ unalign) - ++ text (")" ^ printInstrTerminator) - - (* In cabs2cil we have dropped the last argument in the call to - * __builtin_stdarg_start. *) - | Call(None, Lval(Var vi, NoOffset), [marker], l) - when vi.vname = "__builtin_stdarg_start" && not !printCilAsIs -> begin - let last = self#getLastNamedArgument vi.vname in - self#pInstr () (Call(None,Lval(Var vi,NoOffset),[marker; last],l)) - end - - (* In cabs2cil we have dropped the last argument in the call to - * __builtin_next_arg. *) - | Call(res, Lval(Var vi, NoOffset), [ ], l) - when vi.vname = "__builtin_next_arg" && not !printCilAsIs -> begin - let last = self#getLastNamedArgument vi.vname in - self#pInstr () (Call(res,Lval(Var vi,NoOffset),[last],l)) - end - - (* In cparser we have turned the call to - * __builtin_types_compatible_p(t1, t2) into - * __builtin_types_compatible_p(sizeof t1, sizeof t2), so that we can - * represent the types as expressions. - * Remove the sizeofs when printing. *) - | Call(dest, Lval(Var vi, NoOffset), [SizeOf t1; SizeOf t2], l) - when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> - self#pLineDirective l - (* Print the destination *) - ++ (match dest with - None -> nil - | Some lv -> self#pLval () lv ++ text " = ") - (* Now the call itself *) - ++ dprintf "%s(%a, %a)" vi.vname - (self#pType None) t1 (self#pType None) t2 - ++ text printInstrTerminator - | Call(_, Lval(Var vi, NoOffset), _, l) - when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> - E.s (bug "__builtin_types_compatible_p: cabs2cil should have added sizeof to the arguments.") - - | Call(dest,e,args,l) -> - self#pLineDirective l - ++ (match dest with - None -> nil - | Some lv -> - self#pLval () lv ++ text " = " ++ - (* Maybe we need to print a cast *) - (let destt = typeOfLval lv in - match unrollType (typeOf e) with - TFun (rt, _, _, _) - when not (Util.equals (!pTypeSig rt) - (!pTypeSig destt)) -> - text "(" ++ self#pType None () destt ++ text ")" - | _ -> nil)) - (* Now the function name *) - ++ (let ed = self#pExp () e in - match e with - Lval(Var _, _) -> ed - | _ -> text "(" ++ ed ++ text ")") - ++ text "(" ++ - (align - (* Now the arguments *) - ++ (docList ~sep:(chr ',' ++ break) - (self#pExp ()) () args) - ++ unalign) - ++ text (")" ^ printInstrTerminator) - - | Asm(attrs, tmpls, outs, ins, clobs, l) -> - if !msvcMode then - self#pLineDirective l - ++ text "__asm {" - ++ (align - ++ (docList ~sep:line text () tmpls) - ++ unalign) - ++ text ("}" ^ printInstrTerminator) - else - self#pLineDirective l - ++ text ("__asm__ ") - ++ self#pAttrs () attrs - ++ text " (" - ++ (align - ++ (docList ~sep:line - (fun x -> text ("\"" ^ escape_string x ^ "\"")) - () tmpls) - ++ - (if outs = [] && ins = [] && clobs = [] then - chr ':' - else - (text ": " - ++ (docList ~sep:(chr ',' ++ break) - (fun (c, lv) -> - text ("\"" ^ escape_string c ^ "\" (") - ++ self#pLval () lv - ++ text ")") () outs))) - ++ - (if ins = [] && clobs = [] then - nil - else - (text ": " - ++ (docList ~sep:(chr ',' ++ break) - (fun (c, e) -> - text ("\"" ^ escape_string c ^ "\" (") - ++ self#pExp () e - ++ text ")") () ins))) - ++ - (if clobs = [] then nil - else - (text ": " - ++ (docList ~sep:(chr ',' ++ break) - (fun c -> text ("\"" ^ escape_string c ^ "\"")) - () - clobs))) - ++ unalign) - ++ text (")" ^ printInstrTerminator) - - - (**** STATEMENTS ****) - method pStmt () (s:stmt) = (* control-flow statement *) - self#pStmtNext invalidStmt () s - - method dStmt (out: out_channel) (ind: int) (s:stmt) : unit = - fprint out !lineLength (indent ind (self#pStmt () s)) - - method dBlock (out: out_channel) (ind: int) (b:block) : unit = - fprint out !lineLength (indent ind (align ++ self#pBlock () b)) - - method private pStmtNext (next: stmt) () (s: stmt) = - (* print the labels *) - ((docList ~sep:line (fun l -> self#pLabel () l)) () s.labels) - (* print the statement itself. If the labels are non-empty and the - * statement is empty, print a semicolon *) - ++ - (if s.skind = Instr [] && s.labels <> [] then - text ";" - else - (if s.labels <> [] then line else nil) - ++ self#pStmtKind next () s.skind) - - method private pLabel () = function - Label (s, _, true) -> text (s ^ ": ") - | Label (s, _, false) -> text (s ^ ": /* CIL Label */ ") - | Case (e, _) -> text "case " ++ self#pExp () e ++ text ": " - | Default _ -> text "default: " - - (* The pBlock will put the unalign itself *) - method pBlock () (blk: block) = - let rec dofirst () = function - [] -> nil - | [x] -> self#pStmtNext invalidStmt () x - | x :: rest -> dorest nil x rest - and dorest acc prev = function - [] -> acc ++ (self#pStmtNext invalidStmt () prev) - | x :: rest -> - dorest (acc ++ (self#pStmtNext x () prev) ++ line) - x rest - in - (* Let the host of the block decide on the alignment. The d_block will - * pop the alignment as well *) - text "{" - ++ - (if blk.battrs <> [] then - self#pAttrsGen true blk.battrs - else nil) - ++ line - ++ (dofirst () blk.bstmts) - ++ unalign ++ line ++ text "}" - - - (* Store here the name of the last file printed in a line number. This is - * private to the object *) - val mutable lastFileName = "" - (* Make sure that you only call self#pLineDirective on an empty line *) - method pLineDirective ?(forcefile=false) l = - currentLoc := l; - match !lineDirectiveStyle with - | Some style when l.line > 0 -> - let directive = - match style with - | LineComment -> text "//#line " - | LinePreprocessorOutput when not !msvcMode -> chr '#' - | _ -> text "#line" - in - let filename = - if forcefile || l.file <> lastFileName then - begin - lastFileName <- l.file; - text " \"" ++ text l.file ++ text "\"" - end - else - nil - in - leftflush ++ directive ++ chr ' ' ++ num l.line ++ filename ++ line - | _ -> - nil - - - method private pStmtKind (next: stmt) () = function - Return(None, l) -> - self#pLineDirective l - ++ text "return;" - - | Return(Some e, l) -> - self#pLineDirective l - ++ text "return (" - ++ self#pExp () e - ++ text ");" - - | Goto (sref, l) -> begin - (* Grab one of the labels *) - let rec pickLabel = function - [] -> None - | Label (l, _, _) :: _ -> Some l - | _ :: rest -> pickLabel rest - in - match pickLabel !sref.labels with - Some l -> text ("goto " ^ l ^ ";") - | None -> - ignore (error "Cannot find label for target of goto\n"); - text "goto __invalid_label;" - end - - | Break l -> - self#pLineDirective l - ++ text "break;" - - | Continue l -> - self#pLineDirective l - ++ text "continue;" - - | Instr il -> - align - ++ (docList ~sep:line (fun i -> self#pInstr () i) () il) - ++ unalign - - | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs -> - self#pLineDirective l - ++ text "if" - ++ (align - ++ text " (" - ++ self#pExp () be - ++ text ") " - ++ self#pBlock () t) - - | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}]; - battrs=[]},l) - when !gref == next && not !printCilAsIs -> - self#pLineDirective l - ++ text "if" - ++ (align - ++ text " (" - ++ self#pExp () be - ++ text ") " - ++ self#pBlock () t) - - | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs -> - self#pLineDirective l - ++ text "if" - ++ (align - ++ text " (" - ++ self#pExp () (UnOp(LNot,be,intType)) - ++ text ") " - ++ self#pBlock () e) - - | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}]; - battrs=[]},e,l) - when !gref == next && not !printCilAsIs -> - self#pLineDirective l - ++ text "if" - ++ (align - ++ text " (" - ++ self#pExp () (UnOp(LNot,be,intType)) - ++ text ") " - ++ self#pBlock () e) - - | If(be,t,e,l) -> - self#pLineDirective l - ++ (align - ++ text "if" - ++ (align - ++ text " (" - ++ self#pExp () be - ++ text ") " - ++ self#pBlock () t) - ++ text " " (* sm: indent next code 2 spaces (was 4) *) - ++ (align - ++ text "else " - ++ self#pBlock () e) - ++ unalign) - - | Switch(e,b,_,l) -> - self#pLineDirective l - ++ (align - ++ text "switch (" - ++ self#pExp () e - ++ text ") " - ++ self#pBlock () b) - -(* - | Loop(b, l, _, _) -> begin - (* Maybe the first thing is a conditional. Turn it into a WHILE *) - try - let term, bodystmts = - let rec skipEmpty = function - [] -> [] - | {skind=Instr [];labels=[]} :: rest -> skipEmpty rest - | x -> x - in - (* Bill McCloskey: Do not remove the If if it has labels *) - match skipEmpty b.bstmts with - {skind=If(e,tb,fb,_); labels=[]} :: rest - when not !printCilAsIs -> begin - match skipEmpty tb.bstmts, skipEmpty fb.bstmts with - [], {skind=Break _; labels=[]} :: _ -> e, rest - | {skind=Break _; labels=[]} :: _, [] - -> UnOp(LNot, e, intType), rest - | _ -> raise Not_found - end - | _ -> raise Not_found - in - self#pLineDirective l - ++ text "wh" - ++ (align - ++ text "ile (" - ++ self#pExp () term - ++ text ") " - ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs}) - - with Not_found -> - self#pLineDirective l - ++ text "wh" - ++ (align - ++ text "ile (1) " - ++ self#pBlock () b) - end -*) - - | While (e, b, l) -> - self#pLineDirective l - ++ (align - ++ text "while (" - ++ self#pExp () e - ++ text ") " - ++ self#pBlock () b) - - | DoWhile (e, b, l) -> - self#pLineDirective l - ++ (align - ++ text "do " - ++ self#pBlock () b - ++ text " while (" - ++ self#pExp () e - ++ text ");") - - | For (bInit, e, bIter, b, l) -> - ignore (E.warn - "in for loops, the 1st and 3rd expressions are not printed"); - self#pLineDirective l - ++ (align - ++ text "for (" - ++ text "/* ??? */" (* self#pBlock () bInit *) - ++ text "; " - ++ self#pExp () e - ++ text "; " - ++ text "/* ??? */" (* self#pBlock() bIter *) - ++ text ") " - ++ self#pBlock () b) - - | Block b -> align ++ self#pBlock () b - - | TryFinally (b, h, l) -> - self#pLineDirective l - ++ text "__try " - ++ align - ++ self#pBlock () b - ++ text " __fin" ++ align ++ text "ally " - ++ self#pBlock () h - - | TryExcept (b, (il, e), h, l) -> - self#pLineDirective l - ++ text "__try " - ++ align - ++ self#pBlock () b - ++ text " __e" ++ align ++ text "xcept(" ++ line - ++ align - (* Print the instructions but with a comma at the end, instead of - * semicolon *) - ++ (printInstrTerminator <- ","; - let res = - (docList ~sep:line (self#pInstr ()) - () il) - in - printInstrTerminator <- ";"; - res) - ++ self#pExp () e - ++ text ") " ++ unalign - ++ self#pBlock () h - - - (*** GLOBALS ***) - method pGlobal () (g:global) : doc = (* global (vars, types, etc.) *) - match g with - | GFun (fundec, l) -> - (* If the function has attributes then print a prototype because - * GCC cannot accept function attributes in a definition *) - let oldattr = fundec.svar.vattr in - (* Always pring the file name before function declarations *) - let proto = - if oldattr <> [] then - (self#pLineDirective l) ++ (self#pVDecl () fundec.svar) - ++ chr ';' ++ line - else nil in - (* Temporarily remove the function attributes *) - fundec.svar.vattr <- []; - let body = (self#pLineDirective ~forcefile:true l) - ++ (self#pFunDecl () fundec) in - fundec.svar.vattr <- oldattr; - proto ++ body ++ line - - | GType (typ, l) -> - self#pLineDirective ~forcefile:true l ++ - text "typedef " - ++ (self#pType (Some (text typ.tname)) () typ.ttype) - ++ text ";\n" - - | GEnumTag (enum, l) -> - self#pLineDirective l ++ - text "enum" ++ align ++ text (" " ^ enum.ename) ++ - text " {" ++ line - ++ (docList ~sep:(chr ',' ++ line) - (fun (n,i, loc) -> - text (n ^ " = ") - ++ self#pExp () i) - () enum.eitems) - ++ unalign ++ line ++ text "} " - ++ self#pAttrs () enum.eattr ++ text";\n" - - | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *) - self#pLineDirective l ++ - text ("enum " ^ enum.ename ^ ";\n") - - | GCompTag (comp, l) -> (* This is a definition of a tag *) - let n = comp.cname in - let su, su1, su2 = - if comp.cstruct then "struct", "str", "uct" - else "union", "uni", "on" - in - let sto_mod, rest_attr = separateStorageModifiers comp.cattr in - self#pLineDirective ~forcefile:true l ++ - text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod) - ++ text n - ++ text " {" ++ line - ++ ((docList ~sep:line (self#pFieldDecl ())) () - comp.cfields) - ++ unalign) - ++ line ++ text "}" ++ - (self#pAttrs () rest_attr) ++ text ";\n" - - | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *) - self#pLineDirective l ++ - text (compFullName comp) ++ text ";\n" - - | GVar (vi, io, l) -> - self#pLineDirective ~forcefile:true l ++ - self#pVDecl () vi - ++ chr ' ' - ++ (match io.init with - None -> nil - | Some i -> text " = " ++ - (let islong = - match i with - CompoundInit (_, il) when List.length il >= 8 -> true - | _ -> false - in - if islong then - line ++ self#pLineDirective l ++ text " " - else nil) ++ - (self#pInit () i)) - ++ text ";\n" - - (* print global variable 'extern' declarations, and function prototypes *) - | GVarDecl (vi, l) -> - self#pLineDirective l ++ - (self#pVDecl () vi) - ++ text ";\n" - - | GAsm (s, l) -> - self#pLineDirective l ++ - text ("__asm__(\"" ^ escape_string s ^ "\");\n") - - | GPragma (Attr(an, args), l) -> - (* sm: suppress printing pragmas that gcc does not understand *) - (* assume anything starting with "ccured" is ours *) - (* also don't print the 'combiner' pragma *) - (* nor 'cilnoremove' *) - let suppress = - not !print_CIL_Input && - not !msvcMode && - ((startsWith "box" an) || - (startsWith "ccured" an) || - (an = "merger") || - (an = "cilnoremove")) in - let d = - match an, args with - | _, [] -> - text an - | "weak", [ACons (symbol, [])] -> - text "weak " ++ text symbol - | _ -> - text (an ^ "(") - ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args - ++ text ")" - in - self#pLineDirective l - ++ (if suppress then text "/* " else text "") - ++ (text "#pragma ") - ++ d - ++ (if suppress then text " */\n" else text "\n") - - | GText s -> - if s <> "//" then - text s ++ text "\n" - else - nil - - - method dGlobal (out: out_channel) (g: global) : unit = - (* For all except functions and variable with initializers, use the - * pGlobal *) - match g with - GFun (fdec, l) -> - (* If the function has attributes then print a prototype because - * GCC cannot accept function attributes in a definition *) - let oldattr = fdec.svar.vattr in - let proto = - if oldattr <> [] then - (self#pLineDirective l) ++ (self#pVDecl () fdec.svar) - ++ chr ';' ++ line - else nil in - fprint out !lineLength - (proto ++ (self#pLineDirective ~forcefile:true l)); - (* Temporarily remove the function attributes *) - fdec.svar.vattr <- []; - fprint out !lineLength (self#pFunDecl () fdec); - fdec.svar.vattr <- oldattr; - output_string out "\n" - - | GVar (vi, {init = Some i}, l) -> begin - fprint out !lineLength - (self#pLineDirective ~forcefile:true l ++ - self#pVDecl () vi - ++ text " = " - ++ (let islong = - match i with - CompoundInit (_, il) when List.length il >= 8 -> true - | _ -> false - in - if islong then - line ++ self#pLineDirective l ++ text " " - else nil)); - self#dInit out 3 i; - output_string out ";\n" - end - - | g -> fprint out !lineLength (self#pGlobal () g) - - method pFieldDecl () fi = - (self#pType - (Some (text (if fi.fname = missingFieldName then "" else fi.fname))) - () - fi.ftype) - ++ text " " - ++ (match fi.fbitfield with None -> nil - | Some i -> text ": " ++ num i ++ text " ") - ++ self#pAttrs () fi.fattr - ++ text ";" - - method private pFunDecl () f = - self#pVDecl () f.svar - ++ line - ++ text "{ " - ++ (align - (* locals. *) - ++ (docList ~sep:line (fun vi -> self#pVDecl () vi ++ text ";") - () f.slocals) - ++ line ++ line - (* the body *) - ++ ((* remember the declaration *) currentFormals <- f.sformals; - let body = self#pBlock () f.sbody in - currentFormals <- []; - body)) - ++ line - ++ text "}" - - (***** PRINTING DECLARATIONS and TYPES ****) - - method pType (nameOpt: doc option) (* Whether we are declaring a name or - * we are just printing a type *) - () (t:typ) = (* use of some type *) - let name = match nameOpt with None -> nil | Some d -> d in - let printAttributes (a: attributes) = - let pa = self#pAttrs () a in - match nameOpt with - | None when not !print_CIL_Input && not !msvcMode -> - (* Cannot print the attributes in this case because gcc does not - * like them here, except if we are printing for CIL, or for MSVC. - * In fact, for MSVC we MUST print attributes such as __stdcall *) - if pa = nil then nil else - text "/*" ++ pa ++ text "*/" - | _ -> pa - in - match t with - TVoid a -> - text "void" - ++ self#pAttrs () a - ++ text " " - ++ name - - | TInt (ikind,a) -> - d_ikind () ikind - ++ self#pAttrs () a - ++ text " " - ++ name - - | TFloat(fkind, a) -> - d_fkind () fkind - ++ self#pAttrs () a - ++ text " " - ++ name - - | TComp (comp, a) -> (* A reference to a struct *) - let su = if comp.cstruct then "struct" else "union" in - text (su ^ " " ^ comp.cname ^ " ") - ++ self#pAttrs () a - ++ name - - | TEnum (enum, a) -> - text ("enum " ^ enum.ename ^ " ") - ++ self#pAttrs () a - ++ name - | TPtr (bt, a) -> - (* Parenthesize the ( * attr name) if a pointer to a function or an - * array. However, on MSVC the __stdcall modifier must appear right - * before the pointer constructor "(__stdcall *f)". We push them into - * the parenthesis. *) - let (paren: doc option), (bt': typ) = - match bt with - TFun(rt, args, isva, fa) when !msvcMode -> - let an, af', at = partitionAttributes ~default:AttrType fa in - (* We take the af' and we put them into the parentheses *) - Some (text "(" ++ printAttributes af'), - TFun(rt, args, isva, addAttributes an at) - - | TFun _ | TArray _ -> Some (text "("), bt - - | _ -> None, bt - in - let name' = text "*" ++ printAttributes a ++ name in - let name'' = (* Put the parenthesis *) - match paren with - Some p -> p ++ name' ++ text ")" - | _ -> name' - in - self#pType - (Some name'') - () - bt' - - | TArray (elemt, lo, a) -> - (* ignore the const attribute for arrays *) - let a' = dropAttributes [ "const" ] a in - let name' = - if a' == [] then name else - if nameOpt == None then printAttributes a' else - text "(" ++ printAttributes a' ++ name ++ text ")" - in - self#pType - (Some (name' - ++ text "[" - ++ (match lo with None -> nil | Some e -> self#pExp () e) - ++ text "]")) - () - elemt - - | TFun (restyp, args, isvararg, a) -> - let name' = - if a == [] then name else - if nameOpt == None then printAttributes a else - text "(" ++ printAttributes a ++ name ++ text ")" - in - self#pType - (Some - (name' - ++ text "(" - ++ (align - ++ - (if args = Some [] && isvararg then - text "..." - else - (if args = None then nil - else if args = Some [] then text "void" - else - let pArg (aname, atype, aattr) = - let stom, rest = separateStorageModifiers aattr in - (* First the storage modifiers *) - (self#pAttrs () stom) - ++ (self#pType (Some (text aname)) () atype) - ++ text " " - ++ self#pAttrs () rest - in - (docList ~sep:(chr ',' ++ break) pArg) () - (argsToList args)) - ++ (if isvararg then break ++ text ", ..." else nil)) - ++ unalign) - ++ text ")")) - () - restyp - - | TNamed (t, a) -> - text t.tname ++ self#pAttrs () a ++ text " " ++ name - - | TBuiltin_va_list a -> - text "__builtin_va_list" - ++ self#pAttrs () a - ++ text " " - ++ name - - - (**** PRINTING ATTRIBUTES *********) - method pAttrs () (a: attributes) = - self#pAttrsGen false a - - - (* Print one attribute. Return also an indication whether this attribute - * should be printed inside the __attribute__ list *) - method pAttr (Attr(an, args): attribute) : doc * bool = - (* Recognize and take care of some known cases *) - match an, args with - "const", [] -> text "const", false - (* Put the aconst inside the attribute list *) - | "aconst", [] when not !msvcMode -> text "__const__", true - | "thread", [] when not !msvcMode -> text "__thread", false -(* - | "used", [] when not !msvcMode -> text "__attribute_used__", false -*) - | "volatile", [] -> text "volatile", false - | "restrict", [] -> text "__restrict", false - | "missingproto", [] -> text "/* missing proto */", false - | "cdecl", [] when !msvcMode -> text "__cdecl", false - | "stdcall", [] when !msvcMode -> text "__stdcall", false - | "fastcall", [] when !msvcMode -> text "__fastcall", false - | "declspec", args when !msvcMode -> - text "__declspec(" - ++ docList (self#pAttrParam ()) () args - ++ text ")", false - | "w64", [] when !msvcMode -> text "__w64", false - | "asm", args -> - text "__asm__(" - ++ docList (self#pAttrParam ()) () args - ++ text ")", false - (* we suppress printing mode(__si__) because it triggers an *) - (* internal compiler error in all current gcc versions *) - (* sm: I've now encountered a problem with mode(__hi__)... *) - (* I don't know what's going on, but let's try disabling all "mode"..*) - | "mode", [ACons(tag,[])] -> - text "/* mode(" ++ text tag ++ text ") */", false - - (* sm: also suppress "format" because we seem to print it in *) - (* a way gcc does not like *) - | "format", _ -> text "/* format attribute */", false - - (* sm: here's another one I don't want to see gcc warnings about.. *) - | "mayPointToStack", _ when not !print_CIL_Input - (* [matth: may be inside another comment.] - -> text "/*mayPointToStack*/", false - *) - -> text "", false - - | _ -> (* This is the dafault case *) - (* Add underscores to the name *) - let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in - if args = [] then - text an', true - else - text (an' ^ "(") - ++ (docList (self#pAttrParam ()) () args) - ++ text ")", - true - - method pAttrParam () = function - | AInt n -> num n - | AStr s -> text ("\"" ^ escape_string s ^ "\"") - | ACons(s, []) -> text s - | ACons(s,al) -> - text (s ^ "(") - ++ (docList (self#pAttrParam ()) () al) - ++ text ")" - | ASizeOfE a -> text "sizeof(" ++ self#pAttrParam () a ++ text ")" - | ASizeOf t -> text "sizeof(" ++ self#pType None () t ++ text ")" - | ASizeOfS ts -> text "sizeof()" - | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")" - | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")" - | AAlignOfS ts -> text "__alignof__()" - | AUnOp(u,a1) -> - (d_unop () u) ++ text " (" ++ (self#pAttrParam () a1) ++ text ")" - - | ABinOp(b,a1,a2) -> - align - ++ text "(" - ++ (self#pAttrParam () a1) - ++ text ") " - ++ (d_binop () b) - ++ break - ++ text " (" ++ (self#pAttrParam () a2) ++ text ") " - ++ unalign - | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s) - - (* A general way of printing lists of attributes *) - method private pAttrsGen (block: bool) (a: attributes) = - (* Scan all the attributes and separate those that must be printed inside - * the __attribute__ list *) - let rec loop (in__attr__: doc list) = function - [] -> begin - match in__attr__ with - [] -> nil - | _ :: _-> - (* sm: added 'forgcc' calls to not comment things out - * if CIL is the consumer; this is to address a case - * Daniel ran into where blockattribute(nobox) was being - * dropped by the merger - *) - (if block then - text (" " ^ (forgcc "/*") ^ " __blockattribute__(") - else - text "__attribute__((") - - ++ (docList ~sep:(chr ',' ++ break) - (fun a -> a)) () in__attr__ - ++ text ")" - ++ (if block then text (forgcc "*/") else text ")") - end - | x :: rest -> - let dx, ina = self#pAttr x in - if ina then - loop (dx :: in__attr__) rest - else - dx ++ text " " ++ loop in__attr__ rest - in - let res = loop [] a in - if res = nil then - res - else - text " " ++ res ++ text " " - -end (* class defaultCilPrinterClass *) - -let defaultCilPrinter = new defaultCilPrinterClass - -(* Top-level printing functions *) -let printType (pp: cilPrinter) () (t: typ) : doc = - pp#pType None () t - -let printExp (pp: cilPrinter) () (e: exp) : doc = - pp#pExp () e - -let printLval (pp: cilPrinter) () (lv: lval) : doc = - pp#pLval () lv - -let printGlobal (pp: cilPrinter) () (g: global) : doc = - pp#pGlobal () g - -let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit = - pp#dGlobal out g - -let printAttr (pp: cilPrinter) () (a: attribute) : doc = - let ad, _ = pp#pAttr a in ad - -let printAttrs (pp: cilPrinter) () (a: attributes) : doc = - pp#pAttrs () a - -let printInstr (pp: cilPrinter) () (i: instr) : doc = - pp#pInstr () i - -let printStmt (pp: cilPrinter) () (s: stmt) : doc = - pp#pStmt () s - -let printBlock (pp: cilPrinter) () (b: block) : doc = - (* We must add the alignment ourselves, beucase pBlock will pop it *) - align ++ pp#pBlock () b - -let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit = - pp#dStmt out ind s - -let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit = - pp#dBlock out ind b - -let printInit (pp: cilPrinter) () (i: init) : doc = - pp#pInit () i - -let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit = - pp#dInit out ind i - -(* Now define some short cuts *) -let d_exp () e = printExp defaultCilPrinter () e -let _ = pd_exp := d_exp -let d_lval () lv = printLval defaultCilPrinter () lv -let d_offset base () off = defaultCilPrinter#pOffset base off -let d_init () i = printInit defaultCilPrinter () i -let d_type () t = printType defaultCilPrinter () t -let d_global () g = printGlobal defaultCilPrinter () g -let d_attrlist () a = printAttrs defaultCilPrinter () a -let d_attr () a = printAttr defaultCilPrinter () a -let d_attrparam () e = defaultCilPrinter#pAttrParam () e -let d_label () l = defaultCilPrinter#pLabel () l -let d_stmt () s = printStmt defaultCilPrinter () s -let d_block () b = printBlock defaultCilPrinter () b -let d_instr () i = printInstr defaultCilPrinter () i - -let d_shortglobal () = function - GPragma (Attr(an, _), _) -> dprintf "#pragma %s" an - | GType (ti, _) -> dprintf "typedef %s" ti.tname - | GVarDecl (vi, _) -> dprintf "declaration of %s" vi.vname - | GVar (vi, _, _) -> dprintf "definition of %s" vi.vname - | GCompTag(ci,_) -> dprintf "definition of %s" (compFullName ci) - | GCompTagDecl(ci,_) -> dprintf "declaration of %s" (compFullName ci) - | GEnumTag(ei,_) -> dprintf "definition of enum %s" ei.ename - | GEnumTagDecl(ei,_) -> dprintf "declaration of enum %s" ei.ename - | GFun(fd, _) -> dprintf "definition of %s" fd.svar.vname - | GText _ -> text "GText" - | GAsm _ -> text "GAsm" - - -(* sm: given an ordinary CIL object printer, yield one which - * behaves the same, except it never prints #line directives - * (this is useful for debugging printfs) *) -let dn_obj (func: unit -> 'a -> doc) : (unit -> 'a -> doc) = -begin - (* construct the closure to return *) - let theFunc () (obj:'a) : doc = - begin - let prevStyle = !lineDirectiveStyle in - lineDirectiveStyle := None; - let ret = (func () obj) in (* call underlying printer *) - lineDirectiveStyle := prevStyle; - ret - end in - theFunc -end - -(* now define shortcuts for the non-location-printing versions, - * with the naming prefix "dn_" *) -let dn_exp = (dn_obj d_exp) -let dn_lval = (dn_obj d_lval) -(* dn_offset is missing because it has a different interface *) -let dn_init = (dn_obj d_init) -let dn_type = (dn_obj d_type) -let dn_global = (dn_obj d_global) -let dn_attrlist = (dn_obj d_attrlist) -let dn_attr = (dn_obj d_attr) -let dn_attrparam = (dn_obj d_attrparam) -let dn_stmt = (dn_obj d_stmt) -let dn_instr = (dn_obj d_instr) - - -(* Now define a cilPlainPrinter *) -class plainCilPrinterClass = - (* We keep track of the composite types that we have done to avoid - * recursion *) - let donecomps : (int, unit) H.t = H.create 13 in - object (self) - - inherit defaultCilPrinterClass as super - - (*** PLAIN TYPES ***) - method pType (dn: doc option) () (t: typ) = - match dn with - None -> self#pOnlyType () t - | Some d -> d ++ text " : " ++ self#pOnlyType () t - - method private pOnlyType () = function - TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a - | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])" - d_ikind ikind self#pAttrs a - | TFloat(fkind, a) -> - dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a - | TNamed (t, a) -> - dprintf "TNamed(@[%s,@?%a,@?%a@])" - t.tname self#pOnlyType t.ttype self#pAttrs a - | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a - | TArray(t,l,a) -> - let dl = match l with - None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in - dprintf "TArray(@[%a,@?%a,@?%a@])" - self#pOnlyType t insert dl self#pAttrs a - | TEnum(enum,a) -> dprintf "Enum(%s,@[%a@])" enum.ename self#pAttrs a - | TFun(tr,args,isva,a) -> - dprintf "TFun(@[%a,@?%a%s,@?%a@])" - self#pOnlyType tr - insert - (if args = None then text "None" - else (docList ~sep:(chr ',' ++ break) - (fun (an,at,aa) -> - dprintf "%s: %a" an self#pOnlyType at)) - () - (argsToList args)) - (if isva then "..." else "") self#pAttrs a - | TComp (comp, a) -> - if H.mem donecomps comp.ckey then - dprintf "TCompLoop(%s %s, _, %a)" - (if comp.cstruct then "struct" else "union") comp.cname - self#pAttrs comp.cattr - else begin - H.add donecomps comp.ckey (); (* Add it before we do the fields *) - dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])" - (if comp.cstruct then "struct" else "union") comp.cname - (docList ~sep:(chr ',' ++ break) - (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype)) - comp.cfields - self#pAttrs comp.cattr - self#pAttrs a - end - | TBuiltin_va_list a -> - dprintf "TBuiltin_va_list(%a)" self#pAttrs a - - - (* Some plain pretty-printers. Unlike the above these expose all the - * details of the internal representation *) - method pExp () = function - Const(c) -> - let d_plainconst () c = - match c with - CInt64(i, ik, so) -> - dprintf "Int64(%s,%a,%s)" - (Int64.format "%d" i) - d_ikind ik - (match so with Some s -> s | _ -> "None") - | CStr(s) -> - text ("CStr(\"" ^ escape_string s ^ "\")") - | CWStr(s) -> - dprintf "CWStr(%a)" d_const c - - | CChr(c) -> text ("CChr('" ^ escape_char c ^ "')") - | CReal(f, fk, so) -> - dprintf "CReal(%f, %a, %s)" - f - d_fkind fk - (match so with Some s -> s | _ -> "None") - | CEnum(_, s, _) -> text s - in - text "Const(" ++ d_plainconst () c ++ text ")" - - - | Lval(lv) -> - text "Lval(" - ++ (align - ++ self#pLval () lv - ++ unalign) - ++ text ")" - - | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e - - | UnOp(u,e1,_) -> - dprintf "UnOp(@[%a,@?%a@])" - d_unop u self#pExp e1 - - | BinOp(b,e1,e2,_) -> - let d_plainbinop () b = - match b with - PlusA -> text "PlusA" - | PlusPI -> text "PlusPI" - | IndexPI -> text "IndexPI" - | MinusA -> text "MinusA" - | MinusPP -> text "MinusPP" - | MinusPI -> text "MinusPI" - | _ -> d_binop () b - in - dprintf "%a(@[%a,@?%a@])" d_plainbinop b - self#pExp e1 self#pExp e2 - - | SizeOf (t) -> - text "sizeof(" ++ self#pType None () t ++ chr ')' - | SizeOfE (e) -> - text "sizeofE(" ++ self#pExp () e ++ chr ')' - | SizeOfStr (s) -> - text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')' - | AlignOf (t) -> - text "__alignof__(" ++ self#pType None () t ++ chr ')' - | AlignOfE (e) -> - text "__alignof__(" ++ self#pExp () e ++ chr ')' - - | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv - | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv - - - - method private d_plainoffset () = function - NoOffset -> text "NoOffset" - | Field(fi,o) -> - dprintf "Field(@[%s:%a,@?%a@])" - fi.fname self#pOnlyType fi.ftype self#d_plainoffset o - | Index(e, o) -> - dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o - - method pInit () = function - SingleInit e -> dprintf "SI(%a)" d_exp e - | CompoundInit (t, initl) -> - let d_plainoneinit (o, i) = - self#d_plainoffset () o ++ text " = " ++ self#pInit () i - in - dprintf "CI(@[%a,@?%a@])" self#pOnlyType t - (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl -(* - | ArrayInit (t, len, initl) -> - let idx = ref (- 1) in - let d_plainoneinit i = - incr idx; - text "[" ++ num !idx ++ text "] = " ++ self#pInit () i - in - dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len - (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl -*) - method pLval () (lv: lval) = - match lv with - | Var vi, o -> dprintf "Var(@[%s,@?%a@])" vi.vname self#d_plainoffset o - | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o - - -end -let plainCilPrinter = new plainCilPrinterClass - -(* And now some shortcuts *) -let d_plainexp () e = plainCilPrinter#pExp () e -let d_plaintype () t = plainCilPrinter#pType None () t -let d_plaininit () i = plainCilPrinter#pInit () i -let d_plainlval () l = plainCilPrinter#pLval () l - -(* zra: this allows pretty printers not in cil.ml to - be exposed to cilmain.ml *) -let printerForMaincil = ref defaultCilPrinter - -let rec d_typsig () = function - TSArray (ts, eo, al) -> - dprintf "TSArray(@[%a,@?%a,@?%a@])" - d_typsig ts - insert (text (match eo with None -> "None" - | Some e -> "Some " ^ Int64.to_string e)) - d_attrlist al - | TSPtr (ts, al) -> - dprintf "TSPtr(@[%a,@?%a@])" - d_typsig ts d_attrlist al - | TSComp (iss, name, al) -> - dprintf "TSComp(@[%s %s,@?%a@])" - (if iss then "struct" else "union") name - d_attrlist al - | TSFun (rt, args, isva, al) -> - dprintf "TSFun(@[%a,@?%a,%b,@?%a@])" - d_typsig rt - (docList ~sep:(chr ',' ++ break) (d_typsig ())) args isva - d_attrlist al - | TSEnum (n, al) -> - dprintf "TSEnum(@[%s,@?%a@])" - n d_attrlist al - | TSBase t -> dprintf "TSBase(%a)" d_type t - - -let newVID () = - let t = !nextGlobalVID in - incr nextGlobalVID; - t - - (* Make a varinfo. Used mostly as a helper function below *) -let makeVarinfo global name typ = - (* Strip const from type for locals *) - let vi = - { vname = name; - vid = newVID (); - vglob = global; - vtype = if global then typ else typeRemoveAttributes ["const"] typ; - vdecl = lu; - vinline = false; - vattr = []; - vstorage = NoStorage; - vaddrof = false; - vreferenced = false; (* sm *) - } in - vi - -let copyVarinfo (vi: varinfo) (newname: string) : varinfo = - let vi' = {vi with vname = newname; vid = newVID () } in - vi' - -let makeLocal fdec name typ = (* a helper function *) - fdec.smaxid <- 1 + fdec.smaxid; - let vi = makeVarinfo false name typ in - vi - - (* Make a local variable and add it to a function *) -let makeLocalVar fdec ?(insert = true) name typ = - let vi = makeLocal fdec name typ in - if insert then fdec.slocals <- fdec.slocals @ [vi]; - vi - - -let makeTempVar fdec ?(name = "__cil_tmp") typ : varinfo = - let name = name ^ (string_of_int (1 + fdec.smaxid)) in - makeLocalVar fdec name typ - - - (* Set the formals and re-create the function name based on the information*) -let setFormals (f: fundec) (forms: varinfo list) = - f.sformals <- forms; (* Set the formals *) - match unrollType f.svar.vtype with - TFun(rt, _, isva, fa) -> - f.svar.vtype <- - TFun(rt, - Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms), - isva, fa) - | _ -> E.s (E.bug "Set formals. %s does not have function type\n" - f.svar.vname) - - (* Set the types of arguments and results as given by the function type - * passed as the second argument *) -let setFunctionType (f: fundec) (t: typ) = - match unrollType t with - TFun (rt, Some args, va, a) -> - if List.length f.sformals <> List.length args then - E.s (E.bug "setFunctionType: number of arguments differs from the number of formals"); - (* Change the function type. *) - f.svar.vtype <- t; - (* Change the sformals and we know that indirectly we'll change the - * function type *) - List.iter2 - (fun (an,at,aa) f -> - f.vtype <- at; f.vattr <- aa) - args f.sformals - - | _ -> E.s (E.bug "setFunctionType: not a function type") - - - (* Set the types of arguments and results as given by the function type - * passed as the second argument *) -let setFunctionTypeMakeFormals (f: fundec) (t: typ) = - match unrollType t with - TFun (rt, Some args, va, a) -> - if f.sformals <> [] then - E.s (E.warn "setFunctionTypMakeFormals called on function %s with some formals already" - f.svar.vname); - (* Change the function type. *) - f.svar.vtype <- t; - f.sformals <- []; - - f.sformals <- List.map (fun (n,t,a) -> makeLocal f n t) args; - - setFunctionType f t - - | _ -> E.s (E.bug "setFunctionTypeMakeFormals: not a function type: %a" - d_type t) - - -let setMaxId (f: fundec) = - f.smaxid <- List.length f.sformals + List.length f.slocals - - - (* Make a formal variable for a function. Insert it in both the sformals - * and the type of the function. You can optionally specify where to insert - * this one. If where = "^" then it is inserted first. If where = "$" then - * it is inserted last. Otherwise where must be the name of a formal after - * which to insert this. By default it is inserted at the end. *) -let makeFormalVar fdec ?(where = "$") name typ : varinfo = - (* Search for the insertion place *) - let thenewone = ref fdec.svar in (* Just a placeholder *) - let makeit () : varinfo = - let vi = makeLocal fdec name typ in - thenewone := vi; - vi - in - let rec loopFormals = function - [] -> - if where = "$" then [makeit ()] - else E.s (E.error "makeFormalVar: cannot find insert-after formal %s" - where) - | f :: rest when f.vname = where -> f :: makeit () :: rest - | f :: rest -> f :: loopFormals rest - in - let newformals = - if where = "^" then makeit () :: fdec.sformals else - loopFormals fdec.sformals in - setFormals fdec newformals; - !thenewone - - (* Make a global variable. Your responsibility to make sure that the name - * is unique *) -let makeGlobalVar name typ = - let vi = makeVarinfo true name typ in - vi - - - (* Make an empty function *) -let emptyFunction name = - { svar = makeGlobalVar name (TFun(voidType, Some [], false,[])); - smaxid = 0; - slocals = []; - sformals = []; - sbody = mkBlock []; - smaxstmtid = None; - sallstmts = []; - } - - - - (* A dummy function declaration handy for initialization *) -let dummyFunDec = emptyFunction "@dummy" -let dummyFile = - { globals = []; - fileName = ""; - globinit = None; - globinitcalled = false;} - -let saveBinaryFile (cil_file : file) (filename : string) = - let outchan = open_out_bin filename in - Marshal.to_channel outchan cil_file [] ; - close_out outchan - -let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) = - Marshal.to_channel outchan cil_file [] - -let loadBinaryFile (filename : string) : file = - let inchan = open_in_bin filename in - let cil_file = (Marshal.from_channel inchan : file) in - close_in inchan ; - cil_file - - -(* Take the name of a file and make a valid symbol name out of it. There are - * a few chanracters that are not valid in symbols *) -let makeValidSymbolName (s: string) = - let s = String.copy s in (* So that we can update in place *) - let l = String.length s in - for i = 0 to l - 1 do - let c = String.get s i in - let isinvalid = - match c with - '-' | '.' -> true - | _ -> false - in - if isinvalid then - String.set s i '_'; - done; - s - - -(*** Define the visiting engine ****) -(* visit all the nodes in a Cil expression *) -let doVisit (vis: cilVisitor) - (startvisit: 'a -> 'a visitAction) - (children: cilVisitor -> 'a -> 'a) - (node: 'a) : 'a = - let action = startvisit node in - match action with - SkipChildren -> node - | ChangeTo node' -> node' - | _ -> (* DoChildren and ChangeDoChildrenPost *) - let nodepre = match action with - ChangeDoChildrenPost (node', _) -> node' - | _ -> node - in - let nodepost = children vis nodepre in - match action with - ChangeDoChildrenPost (_, f) -> f nodepost - | _ -> nodepost - -(* mapNoCopy is like map but avoid copying the list if the function does not - * change the elements. *) -let rec mapNoCopy (f: 'a -> 'a) = function - [] -> [] - | (i :: resti) as li -> - let i' = f i in - let resti' = mapNoCopy f resti in - if i' != i || resti' != resti then i' :: resti' else li - -let rec mapNoCopyList (f: 'a -> 'a list) = function - [] -> [] - | (i :: resti) as li -> - let il' = f i in - let resti' = mapNoCopyList f resti in - match il' with - [i'] when i' == i && resti' == resti -> li - | _ -> il' @ resti' - -(* A visitor for lists *) -let doVisitList (vis: cilVisitor) - (startvisit: 'a -> 'a list visitAction) - (children: cilVisitor -> 'a -> 'a) - (node: 'a) : 'a list = - let action = startvisit node in - match action with - SkipChildren -> [node] - | ChangeTo nodes' -> nodes' - | _ -> - let nodespre = match action with - ChangeDoChildrenPost (nodespre, _) -> nodespre - | _ -> [node] - in - let nodespost = mapNoCopy (children vis) nodespre in - match action with - ChangeDoChildrenPost (_, f) -> f nodespost - | _ -> nodespost - -let debugVisit = false - -let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp = - doVisit vis vis#vexpr childrenExp e -and childrenExp (vis: cilVisitor) (e: exp) : exp = - let vExp e = visitCilExpr vis e in - let vTyp t = visitCilType vis t in - let vLval lv = visitCilLval vis lv in - match e with - | Const (CEnum(v, s, ei)) -> - let v' = vExp v in - if v' != v then Const (CEnum(v', s, ei)) else e - - | Const _ -> e - | SizeOf t -> - let t'= vTyp t in - if t' != t then SizeOf t' else e - | SizeOfE e1 -> - let e1' = vExp e1 in - if e1' != e1 then SizeOfE e1' else e - | SizeOfStr s -> e - - | AlignOf t -> - let t' = vTyp t in - if t' != t then AlignOf t' else e - | AlignOfE e1 -> - let e1' = vExp e1 in - if e1' != e1 then AlignOfE e1' else e - | Lval lv -> - let lv' = vLval lv in - if lv' != lv then Lval lv' else e - | UnOp (uo, e1, t) -> - let e1' = vExp e1 in let t' = vTyp t in - if e1' != e1 || t' != t then UnOp(uo, e1', t') else e - | BinOp (bo, e1, e2, t) -> - let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in - if e1' != e1 || e2' != e2 || t' != t then BinOp(bo, e1',e2',t') else e - | CastE (t, e1) -> - let t' = vTyp t in let e1' = vExp e1 in - if t' != t || e1' != e1 then CastE(t', e1') else e - | AddrOf lv -> - let lv' = vLval lv in - if lv' != lv then AddrOf lv' else e - | StartOf lv -> - let lv' = vLval lv in - if lv' != lv then StartOf lv' else e - -and visitCilInit (vis: cilVisitor) (i: init) : init = - doVisit vis vis#vinit childrenInit i -and childrenInit (vis: cilVisitor) (i: init) : init = - let fExp e = visitCilExpr vis e in - let fInit i = visitCilInit vis i in - let fTyp t = visitCilType vis t in - match i with - | SingleInit e -> - let e' = fExp e in - if e' != e then SingleInit e' else i - | CompoundInit (t, initl) -> - let t' = fTyp t in - (* Collect the new initializer list, in reverse. We prefer two - * traversals to ensure tail-recursion. *) - let newinitl : (offset * init) list ref = ref [] in - (* Keep track whether the list has changed *) - let hasChanged = ref false in - let doOneInit ((o, i) as oi) = - let o' = visitCilInitOffset vis o in (* use initializer version *) - let i' = fInit i in - let newio = - if o' != o || i' != i then - begin hasChanged := true; (o', i') end else oi - in - newinitl := newio :: !newinitl - in - List.iter doOneInit initl; - let initl' = if !hasChanged then List.rev !newinitl else initl in - if t' != t || initl' != initl then CompoundInit (t', initl') else i - -and visitCilLval (vis: cilVisitor) (lv: lval) : lval = - doVisit vis vis#vlval childrenLval lv -and childrenLval (vis: cilVisitor) (lv: lval) : lval = - (* and visit its subexpressions *) - let vExp e = visitCilExpr vis e in - let vOff off = visitCilOffset vis off in - match lv with - Var v, off -> - let v' = doVisit vis vis#vvrbl (fun _ x -> x) v in - let off' = vOff off in - if v' != v || off' != off then Var v', off' else lv - | Mem e, off -> - let e' = vExp e in - let off' = vOff off in - if e' != e || off' != off then Mem e', off' else lv - -and visitCilOffset (vis: cilVisitor) (off: offset) : offset = - doVisit vis vis#voffs childrenOffset off -and childrenOffset (vis: cilVisitor) (off: offset) : offset = - let vOff off = visitCilOffset vis off in - match off with - Field (f, o) -> - let o' = vOff o in - if o' != o then Field (f, o') else off - | Index (e, o) -> - let e' = visitCilExpr vis e in - let o' = vOff o in - if e' != e || o' != o then Index (e', o') else off - | NoOffset -> off - -(* sm: for offsets in initializers, the 'startvisit' will be the - * vinitoffs method, but we can re-use the childrenOffset from - * above since recursive offsets are visited by voffs. (this point - * is moot according to cil.mli which claims the offsets in - * initializers will never recursively contain offsets) - *) -and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset = - doVisit vis vis#vinitoffs childrenOffset off - -and visitCilInstr (vis: cilVisitor) (i: instr) : instr list = - let oldloc = !currentLoc in - currentLoc := (get_instrLoc i); - assertEmptyQueue vis; - let res = doVisitList vis vis#vinst childrenInstr i in - currentLoc := oldloc; - (* See if we have accumulated some instructions *) - vis#unqueueInstr () @ res - -and childrenInstr (vis: cilVisitor) (i: instr) : instr = - let fExp = visitCilExpr vis in - let fLval = visitCilLval vis in - match i with - | Set(lv,e,l) -> - let lv' = fLval lv in let e' = fExp e in - if lv' != lv || e' != e then Set(lv',e',l) else i - | Call(None,f,args,l) -> - let f' = fExp f in let args' = mapNoCopy fExp args in - if f' != f || args' != args then Call(None,f',args',l) else i - | Call(Some lv,fn,args,l) -> - let lv' = fLval lv in let fn' = fExp fn in - let args' = mapNoCopy fExp args in - if lv' != lv || fn' != fn || args' != args - then Call(Some lv', fn', args', l) else i - - | Asm(sl,isvol,outs,ins,clobs,l) -> - let outs' = mapNoCopy (fun ((s,lv) as pair) -> - let lv' = fLval lv in - if lv' != lv then (s,lv') else pair) outs in - let ins' = mapNoCopy (fun ((s,e) as pair) -> - let e' = fExp e in - if e' != e then (s,e') else pair) ins in - if outs' != outs || ins' != ins then - Asm(sl,isvol,outs',ins',clobs,l) else i - - -(* visit all nodes in a Cil statement tree in preorder *) -and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt = - let oldloc = !currentLoc in - currentLoc := (get_stmtLoc s.skind) ; - assertEmptyQueue vis; - let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *) - let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in - (* Now see if we have saved some instructions *) - toPrepend := !toPrepend @ vis#unqueueInstr (); - (match !toPrepend with - [] -> () (* Return the same statement *) - | _ -> - (* Make our statement contain the instructions to prepend *) - res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend); - mkStmt res.skind ] }); - currentLoc := oldloc; - res - -and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt = - let fExp e = (visitCilExpr vis e) in - let fBlock b = visitCilBlock vis b in - let fInst i = visitCilInstr vis i in - (* Just change the statement kind *) - let skind' = - match s.skind with - Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind - | Return (Some e, l) -> - let e' = fExp e in - if e' != e then Return (Some e', l) else s.skind -(* - | Loop (b, l, s1, s2) -> - let b' = fBlock b in - if b' != b then Loop (b', l, s1, s2) else s.skind -*) - | While (e, b, l) -> - let e' = fExp e in - let b' = fBlock b in - if e' != e || b' != b then While (e', b', l) else s.skind - | DoWhile (e, b, l) -> - let b' = fBlock b in - let e' = fExp e in - if e' != e || b' != b then DoWhile (e', b', l) else s.skind - | For (bInit, e, bIter, b, l) -> - let bInit' = fBlock bInit in - let e' = fExp e in - let bIter' = fBlock bIter in - let b' = fBlock b in - if bInit' != bInit || e' != e || bIter' != bIter || b' != b then - For (bInit', e', bIter', b', l) else s.skind - | If(e, s1, s2, l) -> - let e' = fExp e in - (*if e queued any instructions, pop them here and remember them so that - they are inserted before the If stmt, not in the then block. *) - toPrepend := vis#unqueueInstr (); - let s1'= fBlock s1 in let s2'= fBlock s2 in - (* the stmts in the blocks should have cleaned up after themselves.*) - assertEmptyQueue vis; - if e' != e || s1' != s1 || s2' != s2 then - If(e', s1', s2', l) else s.skind - | Switch (e, b, stmts, l) -> - let e' = fExp e in - toPrepend := vis#unqueueInstr (); (* insert these before the switch *) - let b' = fBlock b in - (* the stmts in b should have cleaned up after themselves.*) - assertEmptyQueue vis; - (* Don't do stmts, but we better not change those *) - if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind - | Instr il -> - let il' = mapNoCopyList fInst il in - if il' != il then Instr il' else s.skind - | Block b -> - let b' = fBlock b in - if b' != b then Block b' else s.skind - | TryFinally (b, h, l) -> - let b' = fBlock b in - let h' = fBlock h in - if b' != b || h' != h then TryFinally(b', h', l) else s.skind - | TryExcept (b, (il, e), h, l) -> - let b' = fBlock b in - assertEmptyQueue vis; - (* visit the instructions *) - let il' = mapNoCopyList fInst il in - (* Visit the expression *) - let e' = fExp e in - let il'' = - let more = vis#unqueueInstr () in - if more != [] then - il' @ more - else - il' - in - let h' = fBlock h in - (* Now collect the instructions *) - if b' != b || il'' != il || e' != e || h' != h then - TryExcept(b', (il'', e'), h', l) - else s.skind - in - if skind' != s.skind then s.skind <- skind'; - (* Visit the labels *) - let labels' = - let fLabel = function - Case (e, l) as lb -> - let e' = fExp e in - if e' != e then Case (e', l) else lb - | lb -> lb - in - mapNoCopy fLabel s.labels - in - if labels' != s.labels then s.labels <- labels'; - s - - - -and visitCilBlock (vis: cilVisitor) (b: block) : block = - doVisit vis vis#vblock childrenBlock b -and childrenBlock (vis: cilVisitor) (b: block) : block = - let fStmt s = visitCilStmt vis s in - let stmts' = mapNoCopy fStmt b.bstmts in - if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b - - -and visitCilType (vis : cilVisitor) (t : typ) : typ = - doVisit vis vis#vtype childrenType t -and childrenType (vis : cilVisitor) (t : typ) : typ = - (* look for types referred to inside t's definition *) - let fTyp t = visitCilType vis t in - let fAttr a = visitCilAttributes vis a in - match t with - TPtr(t1, a) -> - let t1' = fTyp t1 in - let a' = fAttr a in - if t1' != t || a' != a then TPtr(t1', a') else t - | TArray(t1, None, a) -> - let t1' = fTyp t1 in - let a' = fAttr a in - if t1' != t || a' != a then TArray(t1', None, a') else t - | TArray(t1, Some e, a) -> - let t1' = fTyp t1 in - let e' = visitCilExpr vis e in - let a' = fAttr a in - if t1' != t || e' != e || a' != a then TArray(t1', Some e', a') else t - - (* DON'T recurse into the compinfo, this is done in visitCilGlobal. - User can iterate over cinfo.cfields manually, if desired.*) - | TComp(cinfo, a) -> - let a' = fAttr a in - if a != a' then TComp(cinfo, a') else t - - | TFun(rettype, args, isva, a) -> - let rettype' = fTyp rettype in - (* iterate over formals, as variable declarations *) - let argslist = argsToList args in - let visitArg ((an,at,aa) as arg) = - let at' = fTyp at in - let aa' = fAttr aa in - if at' != at || aa' != aa then (an,at',aa') else arg - in - let argslist' = mapNoCopy visitArg argslist in - let a' = fAttr a in - if rettype' != rettype || argslist' != argslist || a' != a then - let args' = if argslist' == argslist then args else Some argslist' in - TFun(rettype', args', isva, a') else t - - | TNamed(t1, a) -> (* Do not go into the type. Will do it at the time of - * GType *) - let a' = fAttr a in - if a' != a then TNamed (t1, a') else t - - | _ -> (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list) - don't contain nested types, but they do have attributes. *) - let a = typeAttrs t in - let a' = fAttr a in - if a' != a then setTypeAttrs t a' else t - - -(* for declarations, we visit the types inside; but for uses, *) -(* we just visit the varinfo node *) -and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = - doVisit vis vis#vvdec childrenVarDecl v -and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = - v.vtype <- visitCilType vis v.vtype; - v.vattr <- visitCilAttributes vis v.vattr; - v - -and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list= - let al' = - mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in - if al' != al then - (* Must re-sort *) - addAttributes al' [] - else - al -and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute = - let fAttrP a = visitCilAttrParams vis a in - match a with - Attr (n, args) -> - let args' = mapNoCopy fAttrP args in - if args' != args then Attr(n, args') else a - - -and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam = - doVisit vis vis#vattrparam childrenAttrparam a -and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam = - let fTyp t = visitCilType vis t in - let fAttrP a = visitCilAttrParams vis a in - match aa with - AInt _ | AStr _ -> aa - | ACons(n, args) -> - let args' = mapNoCopy fAttrP args in - if args' != args then ACons(n, args') else aa - | ASizeOf t -> - let t' = fTyp t in - if t' != t then ASizeOf t' else aa - | ASizeOfE e -> - let e' = fAttrP e in - if e' != e then ASizeOfE e' else aa - | AAlignOf t -> - let t' = fTyp t in - if t' != t then AAlignOf t' else aa - | AAlignOfE e -> - let e' = fAttrP e in - if e' != e then AAlignOfE e' else aa - | ASizeOfS _ | AAlignOfS _ -> - ignore (warn "Visitor inside of a type signature."); - aa - | AUnOp (uo, e1) -> - let e1' = fAttrP e1 in - if e1' != e1 then AUnOp (uo, e1') else aa - | ABinOp (bo, e1, e2) -> - let e1' = fAttrP e1 in - let e2' = fAttrP e2 in - if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa - | ADot (ap, s) -> - let ap' = fAttrP ap in - if ap' != ap then ADot (ap', s) else aa - - -let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec = - if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname); - assertEmptyQueue vis; - let f = doVisit vis vis#vfunc childrenFunction f in - - let toPrepend = vis#unqueueInstr () in - if toPrepend <> [] then - f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts; - f - -and childrenFunction (vis : cilVisitor) (f : fundec) : fundec = - f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *) - (* visit local declarations *) - f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals; - (* visit the formals *) - let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in - (* Make sure the type reflects the formals *) - setFormals f newformals; - (* Remember any new instructions that were generated while visiting - variable declarations. *) - let toPrepend = vis#unqueueInstr () in - - f.sbody <- visitCilBlock vis f.sbody; (* visit the body *) - if toPrepend <> [] then - f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts; - f - -let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list = - (*(trace "visit" (dprintf "visitCilGlobal\n"));*) - let oldloc = !currentLoc in - currentLoc := (get_globalLoc g) ; - currentGlobal := g; - let res = doVisitList vis vis#vglob childrenGlobal g in - currentLoc := oldloc; - res -and childrenGlobal (vis: cilVisitor) (g: global) : global = - match g with - | GFun (f, l) -> - let f' = visitCilFunction vis f in - if f' != f then GFun (f', l) else g - | GType(t, l) -> - t.ttype <- visitCilType vis t.ttype; - g - - | GEnumTagDecl _ | GCompTagDecl _ -> g (* Nothing to visit *) - | GEnumTag (enum, _) -> - (trace "visit" (dprintf "visiting global enum %s\n" enum.ename)); - (* Do the values and attributes of the enumerated items *) - let itemVisit (name, exp, loc) = (name, visitCilExpr vis exp, loc) in - enum.eitems <- mapNoCopy itemVisit enum.eitems; - enum.eattr <- visitCilAttributes vis enum.eattr; - g - - | GCompTag (comp, _) -> - (trace "visit" (dprintf "visiting global comp %s\n" comp.cname)); - (* Do the types and attirbutes of the fields *) - let fieldVisit = fun fi -> - fi.ftype <- visitCilType vis fi.ftype; - fi.fattr <- visitCilAttributes vis fi.fattr - in - List.iter fieldVisit comp.cfields; - comp.cattr <- visitCilAttributes vis comp.cattr; - g - - | GVarDecl(v, l) -> - let v' = visitCilVarDecl vis v in - if v' != v then GVarDecl (v', l) else g - | GVar (v, inito, l) -> - let v' = visitCilVarDecl vis v in - (match inito.init with - None -> () - | Some i -> let i' = visitCilInit vis i in - if i' != i then inito.init <- Some i'); - - if v' != v then GVar (v', inito, l) else g - - | GPragma (a, l) -> begin - match visitCilAttributes vis [a] with - [a'] -> if a' != a then GPragma (a', l) else g - | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute") - end - | _ -> g - - -(** A visitor that does constant folding. If "machdep" is true then we do - * machine dependent simplification (e.g., sizeof) *) -class constFoldVisitorClass (machdep: bool) : cilVisitor = object - inherit nopCilVisitor - - method vinst i = - match i with - (* Skip two functions to which we add Sizeof to the type arguments. - See the comments for these above. *) - Call(_,(Lval (Var vi,NoOffset)),_,_) - when ((vi.vname = "__builtin_va_arg") - || (vi.vname = "__builtin_types_compatible_p")) -> - SkipChildren - | _ -> DoChildren - method vexpr (e: exp) = - (* Do it bottom up *) - ChangeDoChildrenPost (e, constFold machdep) - -end -let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep - -(* Iterate over all globals, including the global initializer *) -let iterGlobals (fl: file) - (doone: global -> unit) : unit = - let doone' g = - currentLoc := get_globalLoc g; - doone g - in - List.iter doone' fl.globals; - (match fl.globinit with - None -> () - | Some g -> doone' (GFun(g, locUnknown))) - -(* Fold over all globals, including the global initializer *) -let foldGlobals (fl: file) - (doone: 'a -> global -> 'a) - (acc: 'a) : 'a = - let doone' acc g = - currentLoc := get_globalLoc g; - doone acc g - in - let acc' = List.fold_left doone' acc fl.globals in - (match fl.globinit with - None -> acc' - | Some g -> doone' acc' (GFun(g, locUnknown))) - - -(* A visitor for the whole file that does not change the globals *) -let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit = - let fGlob g = visitCilGlobal vis g in - iterGlobals f (fun g -> - match fGlob g with - [g'] when g' == g || Util.equals g' g -> () (* Try to do the pointer check first *) - | gl -> - ignore (E.log "You used visitCilFilSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (docList ~sep:line (d_global ())) gl); - ()) - -(* Be careful with visiting the whole file because it might be huge. *) -let visitCilFile (vis : cilVisitor) (f : file) : unit = - let fGlob g = visitCilGlobal vis g in - (* Scan the globals. Make sure this is tail recursive. *) - let rec loop (acc: global list) = function - [] -> f.globals <- List.rev acc - | g :: restg -> - loop ((List.rev (fGlob g)) @ acc) restg - in - loop [] f.globals; - (* the global initializer *) - (match f.globinit with - None -> () - | Some g -> f.globinit <- Some (visitCilFunction vis g)) - - - -(** Create or fetch the global initializer. Tries to put a call to in the the - * function with the main_name *) -let getGlobInit ?(main_name="main") (fl: file) = - match fl.globinit with - Some f -> f - | None -> begin - (* Sadly, we cannot use the Filename library because it does not like - * function names with multiple . in them *) - let f = - let len = String.length fl.fileName in - (* Find the last path separator and record the first . that we see, - * going backwards *) - let lastDot = ref len in - let rec findLastPathSep i = - if i < 0 then -1 else - let c = String.get fl.fileName i in - if c = '/' || c = '\\' then i - else begin - if c = '.' && !lastDot = len then - lastDot := i; - findLastPathSep (i - 1) - end - in - let lastPathSep = findLastPathSep (len - 1) in - let basenoext = - String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1) - in - emptyFunction - (makeValidSymbolName ("__globinit_" ^ basenoext)) - in - fl.globinit <- Some f; - (* Now try to add a call to the global initialized at the beginning of - * main *) - let inserted = ref false in - List.iter - (fun g -> - match g with - GFun(m, lm) when m.svar.vname = main_name -> - (* Prepend a prototype to the global initializer *) - fl.globals <- GVarDecl (f.svar, lm) :: fl.globals; - m.sbody.bstmts <- - compactStmts (mkStmt (Instr [Call(None, - Lval(var f.svar), - [], locUnknown)]) - :: m.sbody.bstmts); - inserted := true; - if !E.verboseFlag then - ignore (E.log "Inserted the globinit\n"); - fl.globinitcalled <- true; - | _ -> ()) - fl.globals; - - if not !inserted then - ignore (E.warn "Cannot find %s to add global initializer %s" - main_name f.svar.vname); - - f - end - - - -(* Fold over all globals, including the global initializer *) -let mapGlobals (fl: file) - (doone: global -> global) : unit = - fl.globals <- List.map doone fl.globals; - (match fl.globinit with - None -> () - | Some g -> begin - match doone (GFun(g, locUnknown)) with - GFun(g', _) -> fl.globinit <- Some g' - | _ -> E.s (E.bug "mapGlobals: globinit is not a function") - end) - - - -let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file = - printDepth := 99999; (* We don't want ... in the output *) - (* If we are in RELEASE mode then we do not print indentation *) - - Pretty.fastMode := true; - - if !E.verboseFlag then - ignore (E.log "printing file %s\n" outfile); - let print x = fprint out 78 x in - print (text ("/* Generated by CIL v. " ^ cilVersion ^ " */\n" ^ - (* sm: I want to easily tell whether the generated output - * is with print_CIL_Input or not *) - "/* print_CIL_Input is " ^ (if !print_CIL_Input then "true" else "false") ^ " */\n\n")); - iterGlobals file (fun g -> dumpGlobal pp out g); - - (* sm: we have to flush the output channel; if we don't then under *) - (* some circumstances (I haven't figure out exactly when, but it happens *) - (* more often with big inputs), we get a truncated output file *) - flush out - - - -(****************** - ****************** - ******************) - - - -(******************** OPTIMIZATIONS *****) -let rec peepHole1 (* Process one statement and possibly replace it *) - (doone: instr -> instr list option) - (* Scan a block and recurse inside nested blocks *) - (ss: stmt list) : unit = - let rec doInstrList (il: instr list) : instr list = - match il with - [] -> [] - | i :: rest -> begin - match doone i with - None -> i :: doInstrList rest - | Some sl -> doInstrList (sl @ rest) - end - in - - List.iter - (fun s -> - match s.skind with - Instr il -> s.skind <- Instr (doInstrList il) - | If (e, tb, eb, _) -> - peepHole1 doone tb.bstmts; - peepHole1 doone eb.bstmts - | Switch (e, b, _, _) -> peepHole1 doone b.bstmts -(* - | Loop (b, l, _, _) -> peepHole1 doone b.bstmts -*) - | While (_, b, _) -> peepHole1 doone b.bstmts - | DoWhile (_, b, _) -> peepHole1 doone b.bstmts - | For (bInit, _, bIter, b, _) -> - peepHole1 doone bInit.bstmts; - peepHole1 doone bIter.bstmts; - peepHole1 doone b.bstmts - | Block b -> peepHole1 doone b.bstmts - | TryFinally (b, h, l) -> - peepHole1 doone b.bstmts; - peepHole1 doone h.bstmts - | TryExcept (b, (il, e), h, l) -> - peepHole1 doone b.bstmts; - peepHole1 doone h.bstmts; - s.skind <- TryExcept(b, (doInstrList il, e), h, l); - | Return _ | Goto _ | Break _ | Continue _ -> ()) - ss - -let rec peepHole2 (* Process two statements and possibly replace them both *) - (dotwo: instr * instr -> instr list option) - (ss: stmt list) : unit = - let rec doInstrList (il: instr list) : instr list = - match il with - [] -> [] - | [i] -> [i] - | (i1 :: ((i2 :: rest) as rest2)) -> - begin - match dotwo (i1,i2) with - None -> i1 :: doInstrList rest2 - | Some sl -> doInstrList (sl @ rest) - end - in - List.iter - (fun s -> - match s.skind with - Instr il -> s.skind <- Instr (doInstrList il) - | If (e, tb, eb, _) -> - peepHole2 dotwo tb.bstmts; - peepHole2 dotwo eb.bstmts - | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts -(* - | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts -*) - | While (_, b, _) -> peepHole2 dotwo b.bstmts - | DoWhile (_, b, _) -> peepHole2 dotwo b.bstmts - | For (bInit, _, bIter, b, _) -> - peepHole2 dotwo bInit.bstmts; - peepHole2 dotwo bIter.bstmts; - peepHole2 dotwo b.bstmts - | Block b -> peepHole2 dotwo b.bstmts - | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts; - peepHole2 dotwo h.bstmts - | TryExcept (b, (il, e), h, l) -> - peepHole2 dotwo b.bstmts; - peepHole2 dotwo h.bstmts; - s.skind <- TryExcept (b, (doInstrList il, e), h, l) - - | Return _ | Goto _ | Break _ | Continue _ -> ()) - ss - - - - -(*** Type signatures ***) - -(* Helper class for typeSig: replace any types in attributes with typsigs *) -class typeSigVisitor(typeSigConverter: typ->typsig) = object - inherit nopCilVisitor - method vattrparam ap = - match ap with - | ASizeOf t -> ChangeTo (ASizeOfS (typeSigConverter t)) - | AAlignOf t -> ChangeTo (AAlignOfS (typeSigConverter t)) - | _ -> DoChildren -end - -let typeSigAddAttrs a0 t = - if a0 == [] then t else - match t with - TSBase t -> TSBase (typeAddAttributes a0 t) - | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a) - | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a) - | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a) - | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a) - | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a) - -(* Compute a type signature. - Use ~ignoreSign:true to convert all signed integer types to unsigned, - so that signed and unsigned will compare the same. *) -let rec typeSigWithAttrs ?(ignoreSign=false) doattr t = - let typeSig = typeSigWithAttrs ~ignoreSign doattr in - let attrVisitor = new typeSigVisitor typeSig in - let doattr al = visitCilAttributes attrVisitor (doattr al) in - match t with - | TInt (ik, al) -> - let ik' = if ignoreSign then begin - match ik with - | ISChar | IChar -> IUChar - | IShort -> IUShort - | IInt -> IUInt - | ILong -> IULong - | ILongLong -> IULongLong - | _ -> ik - end else - ik - in - TSBase (TInt (ik', doattr al)) - | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al)) - | TVoid al -> TSBase (TVoid (doattr al)) - | TEnum (enum, a) -> TSEnum (enum.ename, doattr a) - | TPtr (t, a) -> TSPtr (typeSig t, doattr a) - | TArray (t,l,a) -> (* We do not want fancy expressions in array lengths. - * So constant fold the lengths *) - let l' = - match l with - Some l -> begin - match constFold true l with - Const(CInt64(i, _, _)) -> Some i - | e -> E.s (E.bug "Invalid length in array type: %a\n" - (!pd_exp) e) - end - | None -> None - in - TSArray(typeSig t, l', doattr a) - - | TComp (comp, a) -> - TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a)) - | TFun(rt,args,isva,a) -> - TSFun(typeSig rt, - List.map (fun (_, atype, _) -> (typeSig atype)) (argsToList args), - isva, doattr a) - | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype) - | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al)) - -let typeSig t = - typeSigWithAttrs (fun al -> al) t - -let _ = pTypeSig := typeSig - -(* Remove the attribute from the top-level of the type signature *) -let setTypeSigAttrs (a: attribute list) = function - TSBase t -> TSBase (setTypeAttrs t a) - | TSPtr (ts, _) -> TSPtr (ts, a) - | TSArray (ts, l, _) -> TSArray(ts, l, a) - | TSComp (iss, n, _) -> TSComp (iss, n, a) - | TSEnum (n, _) -> TSEnum (n, a) - | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a) - - -let typeSigAttrs = function - TSBase t -> typeAttrs t - | TSPtr (ts, a) -> a - | TSArray (ts, l, a) -> a - | TSComp (iss, n, a) -> a - | TSEnum (n, a) -> a - | TSFun (ts, tsargs, isva, a) -> a - - - -let dExp: doc -> exp = - fun d -> Const(CStr(sprint !lineLength d)) - -let dInstr: doc -> location -> instr = - fun d l -> Asm([], [sprint !lineLength d], [], [], [], l) - -let dGlobal: doc -> location -> global = - fun d l -> GAsm(sprint !lineLength d, l) - -let rec addOffset (toadd: offset) (off: offset) : offset = - match off with - NoOffset -> toadd - | Field(fid', offset) -> Field(fid', addOffset toadd offset) - | Index(e, offset) -> Index(e, addOffset toadd offset) - - (* Add an offset at the end of an lv *) -let addOffsetLval toadd (b, off) : lval = - b, addOffset toadd off - -let rec removeOffset (off: offset) : offset * offset = - match off with - NoOffset -> NoOffset, NoOffset - | Field(f, NoOffset) -> NoOffset, off - | Index(i, NoOffset) -> NoOffset, off - | Field(f, restoff) -> - let off', last = removeOffset restoff in - Field(f, off'), last - | Index(i, restoff) -> - let off', last = removeOffset restoff in - Index(i, off'), last - -let removeOffsetLval ((b, off): lval) : lval * offset = - let off', last = removeOffset off in - (b, off'), last - - (* Make an AddrOf. Given an lval of type T will give back an expression of - * type ptr(T) *) -let mkAddrOf ((b, off) as lval) : exp = - (* Never take the address of a register variable *) - (match lval with - Var vi, off when vi.vstorage = Register -> vi.vstorage <- NoStorage - | _ -> ()); - match lval with - Mem e, NoOffset -> e - | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)(* array *) - | _ -> AddrOf lval - - -let mkAddrOrStartOf (lv: lval) : exp = - match unrollType (typeOfLval lv) with - TArray _ -> StartOf lv - | _ -> mkAddrOf lv - - - (* Make a Mem, while optimizing AddrOf. The type of the addr must be - * TPtr(t) and the type of the resulting lval is t. Note that in CIL the - * implicit conversion between a function and a pointer to a function does - * not apply. You must do the conversion yourself using AddrOf *) -let mkMem ~(addr: exp) ~(off: offset) : lval = - let res = - match addr, off with - AddrOf lv, _ -> addOffsetLval off lv - | StartOf lv, _ -> (* Must be an array *) - addOffsetLval (Index(zero, off)) lv - | _, _ -> Mem addr, off - in -(* ignore (E.log "memof : %a:%a\nresult = %a\n" - d_plainexp addr d_plainoffset off d_plainexp res); *) - res - - - -let splitFunctionType (ftype: typ) - : typ * (string * typ * attributes) list option * bool * attributes = - match unrollType ftype with - TFun (rt, args, isva, a) -> rt, args, isva, a - | _ -> E.s (bug "splitFunctionType invoked on a non function type %a" - d_type ftype) - -let splitFunctionTypeVI (fvi: varinfo) - : typ * (string * typ * attributes) list option * bool * attributes = - match unrollType fvi.vtype with - TFun (rt, args, isva, a) -> rt, args, isva, a - | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname) - -let isArrayType t = - match unrollType t with - TArray _ -> true - | _ -> false - - -let rec isConstant = function - | Const _ -> true - | UnOp (_, e, _) -> isConstant e - | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2 - | Lval (Var vi, NoOffset) -> - (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype) - | Lval _ -> false - | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true - | CastE (_, e) -> isConstant e - | AddrOf (Var vi, off) | StartOf (Var vi, off) - -> vi.vglob && isConstantOff off - | AddrOf (Mem e, off) | StartOf(Mem e, off) - -> isConstant e && isConstantOff off - -and isConstantOff = function - NoOffset -> true - | Field(fi, off) -> isConstantOff off - | Index(e, off) -> isConstant e && isConstantOff off - - -let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo = - (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields) - - -let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = - (* Do not remove old casts because they are conversions !!! *) - if Util.equals (typeSig oldt) (typeSig newt) then begin - e - end else begin - (* Watch out for constants *) - match newt, e with - TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i - | _ -> CastE(newt,e) - end - -let mkCast ~(e: exp) ~(newt: typ) = - mkCastT e (typeOf e) newt - -type existsAction = - ExistsTrue (* We have found it *) - | ExistsFalse (* Stop processing this branch *) - | ExistsMaybe (* This node is not what we are - * looking for but maybe its - * successors are *) -let existsType (f: typ -> existsAction) (t: typ) : bool = - let memo : (int, unit) H.t = H.create 17 in (* Memo table *) - let rec loop t = - match f t with - ExistsTrue -> true - | ExistsFalse -> false - | ExistsMaybe -> - (match t with - TNamed (t', _) -> loop t'.ttype - | TComp (c, _) -> loopComp c - | TArray (t', _, _) -> loop t' - | TPtr (t', _) -> loop t' - | TFun (rt, args, _, _) -> - (loop rt || List.exists (fun (_, at, _) -> loop at) - (argsToList args)) - | _ -> false) - and loopComp c = - if H.mem memo c.ckey then - (* We are looping, the answer must be false *) - false - else begin - H.add memo c.ckey (); - List.exists (fun f -> loop f.ftype) c.cfields - end - in - loop t - - -(* Try to do an increment, with constant folding *) -let increm (e: exp) (i: int) = - let et = typeOf e in - let bop = if isPointerType et then PlusPI else PlusA in - constFold false (BinOp(bop, e, integer i, et)) - -exception LenOfArray -let lenOfArray (eo: exp option) : int = - match eo with - None -> raise LenOfArray - | Some e -> begin - match constFold true e with - | Const(CInt64(ni, _, _)) when ni >= Int64.zero -> - Int64.to_int ni - | e -> raise LenOfArray - end - - -(*** Make a initializer for zeroe-ing a data type ***) -let rec makeZeroInit (t: typ) : init = - match unrollType t with - TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None))) - | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None))) - | TEnum _ -> SingleInit zero - | TComp (comp, _) as t' when comp.cstruct -> - let inits = - List.fold_right - (fun f acc -> - if f.fname <> missingFieldName then - (Field(f, NoOffset), makeZeroInit f.ftype) :: acc - else - acc) - comp.cfields [] - in - CompoundInit (t', inits) - - | TComp (comp, _) when not comp.cstruct -> - let fstfield, rest = - match comp.cfields with - f :: rest -> f, rest - | [] -> E.s (unimp "Cannot create init for empty union") - in - let fieldToInit = - if !msvcMode then - (* ISO C99 [6.7.8.10] says that the first field of the union - is the one we should initialize. *) - fstfield - else begin - (* gcc initializes the whole union to zero. So choose the largest - field, and set that to zero. Choose the first field if possible. - MSVC also initializes the whole union, but use the ISO behavior - for MSVC because it only allows compound initializers to refer - to the first union field. *) - let fieldSize f = try bitsSizeOf f.ftype with SizeOfError _ -> 0 in - let widestField, widestFieldWidth = - List.fold_left (fun acc thisField -> - let widestField, widestFieldWidth = acc in - let thisSize = fieldSize thisField in - if thisSize > widestFieldWidth then - thisField, thisSize - else - acc) - (fstfield, fieldSize fstfield) - rest - in - widestField - end - in - CompoundInit(t, [(Field(fieldToInit, NoOffset), - makeZeroInit fieldToInit.ftype)]) - - | TArray(bt, Some len, _) as t' -> - let n = - match constFold true len with - Const(CInt64(n, _, _)) -> Int64.to_int n - | _ -> E.s (E.unimp "Cannot understand length of array") - in - let initbt = makeZeroInit bt in - let rec loopElems acc i = - if i < 0 then acc - else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1) - in - CompoundInit(t', loopElems [] (n - 1)) - - | TArray (bt, None, at) as t' -> - (* Unsized array, allow it and fill it in later - * (see cabs2cil.ml, collectInitializer) *) - CompoundInit (t', []) - - | TPtr _ as t -> SingleInit(CastE(t, zero)) - | x -> E.s (unimp "Cannot initialize type: %a" d_type x) - - -(**** Fold over the list of initializers in a Compound. In the case of an - * array initializer only the initializers present are scanned (a prefix of - * all initializers) *) -let foldLeftCompound - ~(doinit: offset -> init -> typ -> 'a -> 'a) - ~(ct: typ) - ~(initl: (offset * init) list) - ~(acc: 'a) : 'a = - match unrollType ct with - TArray(bt, _, _) -> - List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl - - | TComp (comp, _) -> - let getTypeOffset = function - Field(f, NoOffset) -> f.ftype - | _ -> E.s (bug "foldLeftCompound: malformed initializer") - in - List.fold_left - (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl - - | _ -> E.s (unimp "Type of Compound is not array or struct or union") - -(**** Fold over the list of initializers in a Compound. Like foldLeftCompound - * but scans even the zero-initializers that are missing at the end of the - * array *) -let foldLeftCompoundAll - ~(doinit: offset -> init -> typ -> 'a -> 'a) - ~(ct: typ) - ~(initl: (offset * init) list) - ~(acc: 'a) : 'a = - match unrollType ct with - TArray(bt, leno, _) -> begin - let part = - List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in - (* See how many more we have to do *) - match leno with - Some lene -> begin - match constFold true lene with - Const(CInt64(i, _, _)) -> - let len_array = Int64.to_int i in - let len_init = List.length initl in - if len_array > len_init then - let zi = makeZeroInit bt in - let rec loop acc i = - if i >= len_array then acc - else - loop (doinit (Index(integer i, NoOffset)) zi bt acc) - (i + 1) - in - loop part (len_init + 1) - else - part - | _ -> E.s (unimp "foldLeftCompoundAll: array with initializer and non-constant length\n") - end - - | _ -> E.s (unimp "foldLeftCompoundAll: TArray with initializer and no length") - end - | TComp (comp, _) -> - let getTypeOffset = function - Field(f, NoOffset) -> f.ftype - | _ -> E.s (bug "foldLeftCompound: malformed initializer") - in - List.fold_left - (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl - - | _ -> E.s (E.unimp "Type of Compound is not array or struct or union") - - - -let rec isCompleteType t = - match unrollType t with - | TArray(t, None, _) -> false - | TArray(t, Some z, _) when isZero z -> false - | TComp (comp, _) -> (* Struct or union *) - List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields - | _ -> true - - -module A = Alpha - - -(** Uniquefy the variable names *) -let uniqueVarNames (f: file) : unit = - (* Setup the alpha conversion table for globals *) - let gAlphaTable: (string, - location A.alphaTableData ref) H.t = H.create 113 in - (* Keep also track of the global names that we have used. Map them to the - * variable ID. We do this only to check that we do not have two globals - * with the same name. *) - let globalNames: (string, int) H.t = H.create 113 in - (* Scan the file and add the global names to the table *) - iterGlobals f - (function - GVarDecl(vi, l) - | GVar(vi, _, l) - | GFun({svar = vi}, l) -> - (* See if we have used this name already for something else *) - (try - let oldid = H.find globalNames vi.vname in - if oldid <> vi.vid then - ignore (warn "The name %s is used for two distinct globals" - vi.vname); - (* Here if we have used this name already. Go ahead *) - () - with Not_found -> begin - (* Here if this is the first time we define a name *) - H.add globalNames vi.vname vi.vid; - (* And register it *) - A.registerAlphaName gAlphaTable None vi.vname !currentLoc; - () - end) - | _ -> ()); - - (* Now we must scan the function bodies and rename the locals *) - iterGlobals f - (function - GFun(fdec, l) -> begin - currentLoc := l; - (* Setup an undo list to be able to revert the changes to the - * global alpha table *) - let undolist = ref [] in - (* Process one local variable *) - let processLocal (v: varinfo) = - let newname, oldloc = - A.newAlphaName gAlphaTable (Some undolist) v.vname - !currentLoc - in - if false && newname <> v.vname then (* Disable this warning *) - ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)\n" - v.vname fdec.svar.vname newname d_loc oldloc); - v.vname <- newname - in - (* Do the formals first *) - List.iter processLocal fdec.sformals; - (* Fix the type again *) - setFormals fdec fdec.sformals; - (* And now the locals *) - List.iter processLocal fdec.slocals; - (* Undo the changes to the global table *) - A.undoAlphaChanges gAlphaTable !undolist; - () - end - | _ -> ()); - () - - -(* A visitor that makes a deep copy of a function body *) -class copyFunctionVisitor (newname: string) = object (self) - inherit nopCilVisitor - - (* Keep here a maping from locals to their copies *) - val map : (string, varinfo) H.t = H.create 113 - (* Keep here a maping from statements to their copies *) - val stmtmap : (int, stmt) H.t = H.create 113 - val sid = ref 0 (* Will have to assign ids to statements *) - (* Keep here a list of statements to be patched *) - val patches : stmt list ref = ref [] - - val argid = ref 0 - - (* This is the main function *) - method vfunc (f: fundec) : fundec visitAction = - (* We need a map from the old locals/formals to the new ones *) - H.clear map; - argid := 0; - (* Make a copy of the fundec. *) - let f' = {f with svar = f.svar} in - let patchfunction (f' : fundec) = - (* Change the name. Only this late to allow the visitor to copy the - * svar *) - f'.svar.vname <- newname; - let findStmt (i: int) = - try H.find stmtmap i - with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i) - in - let patchstmt (s: stmt) = - match s.skind with - Goto (sr, l) -> - (* Make a copy of the reference *) - let sr' = ref (findStmt !sr.sid) in - s.skind <- Goto (sr',l) - | Switch (e, body, cases, l) -> - s.skind <- Switch (e, body, - List.map (fun cs -> findStmt cs.sid) cases, l) - | _ -> () - in - List.iter patchstmt !patches; - f' - in - patches := []; - sid := 0; - H.clear stmtmap; - ChangeDoChildrenPost (f', patchfunction) - - (* We must create a new varinfo for each declaration. Memoize to - * maintain sharing *) - method vvdec (v: varinfo) = - (* Some varinfo have empty names. Give them some name *) - if v.vname = "" then begin - v.vname <- "arg" ^ string_of_int !argid; incr argid - end; - try - ChangeTo (H.find map v.vname) - with Not_found -> begin - let v' = {v with vid = newVID () } in - H.add map v.vname v'; - ChangeDoChildrenPost (v', fun x -> x) - end - - (* We must replace references to local variables *) - method vvrbl (v: varinfo) = - if v.vglob then SkipChildren else - try - ChangeTo (H.find map v.vname) - with Not_found -> - E.s (bug "Cannot find the new copy of local variable %s" v.vname) - - - (* Replace statements. *) - method vstmt (s: stmt) : stmt visitAction = - s.sid <- !sid; incr sid; - let s' = {s with sid = s.sid} in - H.add stmtmap s.sid s'; (* Remember where we copied this *) - (* if we have a Goto or a Switch remember them to fixup at end *) - (match s'.skind with - (Goto _ | Switch _) -> patches := s' :: !patches - | _ -> ()); - (* Do the children *) - ChangeDoChildrenPost (s', fun x -> x) - - (* Copy blocks since they are mutable *) - method vblock (b: block) = - ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x) - - - method vglob _ = E.s (bug "copyFunction should not be used on globals") -end - -(* We need a function that copies a CIL function. *) -let copyFunction (f: fundec) (newname: string) : fundec = - visitCilFunction (new copyFunctionVisitor(newname)) f - -(********* Compute the CFG ********) -let sid_counter = ref 0 - -let new_sid () = - let id = !sid_counter in - incr sid_counter; - id - -let statements : stmt list ref = ref [] -(* Clear all info about the CFG in statements *) -class clear : cilVisitor = object - inherit nopCilVisitor - method vstmt s = begin - s.sid <- !sid_counter ; - incr sid_counter ; - statements := s :: !statements; - s.succs <- [] ; - s.preds <- [] ; - DoChildren - end - method vexpr _ = SkipChildren - method vtype _ = SkipChildren - method vinst _ = SkipChildren -end - -let link source dest = begin - if not (List.mem dest source.succs) then - source.succs <- dest :: source.succs ; - if not (List.mem source dest.preds) then - dest.preds <- source :: dest.preds -end -let trylink source dest_option = match dest_option with - None -> () -| Some(dest) -> link source dest - - -(** Cmopute the successors and predecessors of a block, given a fallthrough *) -let rec succpred_block b fallthrough = - let rec handle sl = match sl with - [] -> () - | [a] -> succpred_stmt a fallthrough - | hd :: ((next :: _) as tl) -> - succpred_stmt hd (Some next) ; - handle tl - in handle b.bstmts - - -and succpred_stmt s fallthrough = - match s.skind with - Instr _ -> trylink s fallthrough - | Return _ -> () - | Goto(dest,l) -> link s !dest - | Break _ - | Continue _ - | Switch _ -> - failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them." - - | If(e1,b1,b2,l) -> - (match b1.bstmts with - [] -> trylink s fallthrough - | hd :: tl -> (link s hd ; succpred_block b1 fallthrough )) ; - (match b2.bstmts with - [] -> trylink s fallthrough - | hd :: tl -> (link s hd ; succpred_block b2 fallthrough )) - -(* - | Loop(b,l,_,_) -> - begin match b.bstmts with - [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> - link s hd ; - succpred_block b (Some(hd)) - end -*) - - | While (e, b, l) -> begin match b.bstmts with - | [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> link s hd ; - succpred_block b (Some(hd)) - end - - | DoWhile (e, b, l) ->begin match b.bstmts with - | [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> link s hd ; - succpred_block b (Some(hd)) - end - - | For (bInit, e, bIter, b, l) -> - (match bInit.bstmts with - | [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> link s hd ; - succpred_block bInit (Some(hd))) ; - (match bIter.bstmts with - | [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> link s hd ; - succpred_block bIter (Some(hd))) ; - (match b.bstmts with - | [] -> failwith "computeCFGInfo: empty loop" - | hd :: tl -> link s hd ; - succpred_block b (Some(hd))) ; - - | Block(b) -> begin match b.bstmts with - [] -> trylink s fallthrough - | hd :: tl -> link s hd ; - succpred_block b fallthrough - end - | TryExcept _ | TryFinally _ -> - failwith "computeCFGInfo: structured exception handling not implemented" - -(* [weimer] Sun May 5 12:25:24 PDT 2002 - * This code was pulled from ext/switch.ml because it looks like we really - * want it to be part of CIL. - * - * Here is the magic handling to - * (1) replace switch statements with if/goto - * (2) remove "break" - * (3) remove "default" - * (4) remove "continue" - *) -let is_case_label l = match l with - | Case _ | Default _ -> true - | _ -> false - -let switch_count = ref (-1) -let get_switch_count () = - switch_count := 1 + !switch_count ; - !switch_count - -let switch_label = ref (-1) - -let rec xform_switch_stmt s break_dest cont_dest label_index = begin - s.labels <- List.map (fun lab -> match lab with - Label _ -> lab - | Case(e,l) -> - let suffix = - match isInteger e with - | Some value -> - if value < Int64.zero then - "neg_" ^ Int64.to_string (Int64.neg value) - else - Int64.to_string value - | None -> - incr switch_label; - "exp_" ^ string_of_int !switch_label - in - let str = Pretty.sprint !lineLength - (Pretty.dprintf "switch_%d_%s" label_index suffix) in - (Label(str,l,false)) - | Default(l) -> (Label(Printf.sprintf - "switch_%d_default" label_index,l,false)) - ) s.labels ; - match s.skind with - | Instr _ | Return _ | Goto _ -> () - | Break(l) -> begin try - s.skind <- Goto(break_dest (),l) - with e -> - ignore (error "prepareCFG: break: %a@!" d_stmt s) ; - raise e - end - | Continue(l) -> begin try - s.skind <- Goto(cont_dest (),l) - with e -> - ignore (error "prepareCFG: continue: %a@!" d_stmt s) ; - raise e - end - | If(e,b1,b2,l) -> xform_switch_block b1 break_dest cont_dest label_index ; - xform_switch_block b2 break_dest cont_dest label_index - | Switch(e,b,sl,l) -> begin - (* change - * switch (se) { - * case 0: s0 ; - * case 1: s1 ; break; - * ... - * } - * - * into: - * - * if (se == 0) goto label_0; - * else if (se == 1) goto label_1; - * ... - * else if (0) { // body_block - * label_0: s0; - * label_1: s1; goto label_break; - * ... - * } else if (0) { // break_block - * label_break: ; // break_stmt - * } - *) - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- - [Label((Printf.sprintf "switch_%d_break" i),l,false)] ; - let break_block = mkBlock [ break_stmt ] in - let body_block = b in - let body_if_stmtkind = (If(zero,body_block,break_block,l)) in - - (* The default case, if present, must be used only if *all* - non-default cases fail [ISO/IEC 9899:1999, §6.8.4.2, ¶5]. As a - result, we sort the order in which we handle the labels (but not the - order in which we print out the statements, so fall-through still - works as expected). *) - let compare_choices s1 s2 = match s1.labels, s2.labels with - | (Default(_) :: _), _ -> 1 - | _, (Default(_) :: _) -> -1 - | _, _ -> 0 - in - - let rec handle_choices sl = match sl with - [] -> body_if_stmtkind - | stmt_hd :: stmt_tl -> begin - let rec handle_labels lab_list = begin - match lab_list with - [] -> handle_choices stmt_tl - | Case(ce,cl) :: lab_tl -> - let pred = BinOp(Eq,e,ce,intType) in - let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in - let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in - If(pred,then_block,else_block,cl) - | Default(dl) :: lab_tl -> - (* ww: before this was 'if (1) goto label', but as Ben points - out this might confuse someone down the line who doesn't have - special handling for if(1) into thinking that there are two - paths here. The simpler 'goto label' is what we want. *) - Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ; - mkStmt (handle_labels lab_tl) ]) - | Label(_,_,_) :: lab_tl -> handle_labels lab_tl - end in - handle_labels stmt_hd.labels - end in - s.skind <- handle_choices (List.sort compare_choices sl) ; - xform_switch_block b (fun () -> ref break_stmt) cont_dest i - end -(* - | Loop(b,l,_,_) -> - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- - [Label((Printf.sprintf "while_%d_break" i),l,false)] ; - let cont_stmt = mkStmt (Instr []) in - cont_stmt.labels <- - [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; - b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in - let break_dest () = ref break_stmt in - let cont_dest () = ref cont_stmt in - xform_switch_block b break_dest cont_dest label_index ; - break_stmt.succs <- s.succs ; - let new_block = mkBlock [ this_stmt ; break_stmt ] in - s.skind <- Block new_block -*) - | While (e, b, l) -> - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- - [Label((Printf.sprintf "while_%d_break" i),l,false)] ; - let cont_stmt = mkStmt (Instr []) in - cont_stmt.labels <- - [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; - b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (While(e,b,l)) in - let break_dest () = ref break_stmt in - let cont_dest () = ref cont_stmt in - xform_switch_block b break_dest cont_dest label_index ; - break_stmt.succs <- s.succs ; - let new_block = mkBlock [ this_stmt ; break_stmt ] in - s.skind <- Block new_block - - | DoWhile (e, b, l) -> - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- - [Label((Printf.sprintf "while_%d_break" i),l,false)] ; - let cont_stmt = mkStmt (Instr []) in - cont_stmt.labels <- - [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; - b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (DoWhile(e,b,l)) in - let break_dest () = ref break_stmt in - let cont_dest () = ref cont_stmt in - xform_switch_block b break_dest cont_dest label_index ; - break_stmt.succs <- s.succs ; - let new_block = mkBlock [ this_stmt ; break_stmt ] in - s.skind <- Block new_block - - | For (bInit, e, bIter , b, l) -> - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- - [Label((Printf.sprintf "while_%d_break" i),l,false)] ; - let cont_stmt = mkStmt (Instr []) in - cont_stmt.labels <- - [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; - b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (For(bInit,e,bIter,b,l)) in - let break_dest () = ref break_stmt in - let cont_dest () = ref cont_stmt in - xform_switch_block b break_dest cont_dest label_index ; - break_stmt.succs <- s.succs ; - let new_block = mkBlock [ this_stmt ; break_stmt ] in - s.skind <- Block new_block - - - | Block(b) -> xform_switch_block b break_dest cont_dest label_index - - | TryExcept _ | TryFinally _ -> - failwith "xform_switch_statement: structured exception handling not implemented" - -end and xform_switch_block b break_dest cont_dest label_index = - try - let rec link_succs sl = match sl with - | [] -> () - | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl - in - link_succs b.bstmts ; - List.iter (fun stmt -> - xform_switch_stmt stmt break_dest cont_dest label_index) b.bstmts ; - with e -> - List.iter (fun stmt -> ignore - (warn "prepareCFG: %a@!" d_stmt stmt)) b.bstmts ; - raise e - -(* prepare a function for computeCFGInfo by removing break, continue, - * default and switch statements/labels and replacing them with Ifs and - * Gotos. *) -let prepareCFG (fd : fundec) : unit = - xform_switch_block fd.sbody - (fun () -> failwith "prepareCFG: break with no enclosing loop") - (fun () -> failwith "prepareCFG: continue with no enclosing loop") (-1) - -(* make the cfg and return a list of statements *) -let computeCFGInfo (f : fundec) (global_numbering : bool) : unit = - if not global_numbering then - sid_counter := 0 ; - statements := []; - let clear_it = new clear in - ignore (visitCilBlock clear_it f.sbody) ; - f.smaxstmtid <- Some (!sid_counter) ; - succpred_block f.sbody (None); - let res = List.rev !statements in - statements := []; - f.sallstmts <- res; - () - -let initCIL () = - if not !initCIL_called then begin - (* Set the machine *) - theMachine := if !msvcMode then M.msvc else M.gcc; - (* Pick type for string literals *) - stringLiteralType := if !theMachine.M.const_string_literals then - charConstPtrType - else - charPtrType; - (* Find the right ikind given the size *) - let findIkind (unsigned: bool) (sz: int) : ikind = - (* Test the most common sizes first *) - if sz = !theMachine.M.sizeof_int then - if unsigned then IUInt else IInt - else if sz = !theMachine.M.sizeof_long then - if unsigned then IULong else ILong - else if sz = 1 then - if unsigned then IUChar else IChar - else if sz = !theMachine.M.sizeof_short then - if unsigned then IUShort else IShort - else if sz = !theMachine.M.sizeof_longlong then - if unsigned then IULongLong else ILongLong - else - E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz) - in - upointType := TInt(findIkind true !theMachine.M.sizeof_ptr, []); - kindOfSizeOf := findIkind true !theMachine.M.sizeof_sizeof; - typeOfSizeOf := TInt(!kindOfSizeOf, []); - H.add gccBuiltins "__builtin_memset" - (voidPtrType, [ voidPtrType; intType; intType ], false); - wcharKind := findIkind false !theMachine.M.sizeof_wchar; - wcharType := TInt(!wcharKind, []); - char_is_unsigned := !theMachine.M.char_is_unsigned; - little_endian := !theMachine.M.little_endian; - underscore_name := !theMachine.M.underscore_name; - nextGlobalVID := 1; - nextCompinfoKey := 1; - initCIL_called := true - end - - -(* We want to bring all type declarations before the data declarations. This - * is needed for code of the following form: - - int f(); // Prototype without arguments - typedef int FOO; - int f(FOO x) { ... } - - In CIL the prototype also lists the type of the argument as being FOO, - which is undefined. - - There is one catch with this scheme. If the type contains an array whose - length refers to variables then those variables must be declared before - the type *) - -let pullTypesForward = true - - - (* Scan a type and collect the variables that are refered *) -class getVarsInGlobalClass (pacc: varinfo list ref) = object - inherit nopCilVisitor - method vvrbl (vi: varinfo) = - pacc := vi :: !pacc; - SkipChildren - - method vglob = function - GType _ | GCompTag _ -> DoChildren - | _ -> SkipChildren - -end - -let getVarsInGlobal (g : global) : varinfo list = - let pacc : varinfo list ref = ref [] in - let v : cilVisitor = new getVarsInGlobalClass pacc in - ignore (visitCilGlobal v g); - !pacc - -let hasPrefix p s = - let pl = String.length p in - (String.length s >= pl) && String.sub s 0 pl = p - -let pushGlobal (g: global) - ~(types:global list ref) - ~(variables: global list ref) = - if not pullTypesForward then - variables := g :: !variables - else - begin - (* Collect a list of variables that are refered from the type. Return - * Some if the global should go with the types and None if it should go - * to the variables. *) - let varsintype : (varinfo list * location) option = - match g with - GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l) - | GEnumTag (_, l) | GPragma (Attr("pack", _), l) - | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l) - (** Move the warning pragmas early - | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l) - *) - | _ -> None (* Does not go with the types *) - in - match varsintype with - None -> variables := g :: !variables - | Some (vl, loc) -> - types := - (* insert declarations for referred variables ('vl'), before - * the type definition 'g' itself *) - g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc) - !types vl) - end - - -type formatArg = - Fe of exp - | Feo of exp option (** For array lengths *) - | Fu of unop - | Fb of binop - | Fk of ikind - | FE of exp list (** For arguments in a function call *) - | Ff of (string * typ * attributes) (** For a formal argument *) - | FF of (string * typ * attributes) list (* For formal argument lists *) - | Fva of bool (** For the ellipsis in a function type *) - | Fv of varinfo - | Fl of lval - | Flo of lval option (** For the result of a function call *) - | Fo of offset - | Fc of compinfo - | Fi of instr - | FI of instr list - | Ft of typ - | Fd of int - | Fg of string - | Fs of stmt - | FS of stmt list - | FA of attributes - - | Fp of attrparam - | FP of attrparam list - - | FX of string - -let d_formatarg () = function - Fe e -> dprintf "Fe(%a)" d_exp e - | Feo None -> dprintf "Feo(None)" - | Feo (Some e) -> dprintf "Feo(%a)" d_exp e - | FE _ -> dprintf "FE()" - | Fk ik -> dprintf "Fk()" - | Fva b -> dprintf "Fva(%b)" b - | Ff (an, _, _) -> dprintf "Ff(%s)" an - | FF _ -> dprintf "FF(...)" - | FA _ -> dprintf "FA(...)" - | Fu uo -> dprintf "Fu()" - | Fb bo -> dprintf "Fb()" - | Fv v -> dprintf "Fv(%s)" v.vname - | Fl l -> dprintf "Fl(%a)" d_lval l - | Flo None -> dprintf "Flo(None)" - | Flo (Some l) -> dprintf "Flo(%a)" d_lval l - | Fo o -> dprintf "Fo" - | Fc ci -> dprintf "Fc(%s)" ci.cname - | Fi i -> dprintf "Fi(...)" - | FI i -> dprintf "FI(...)" - | Ft t -> dprintf "Ft(%a)" d_type t - | Fd n -> dprintf "Fd(%d)" n - | Fg s -> dprintf "Fg(%s)" s - | Fp _ -> dprintf "Fp(...)" - | FP n -> dprintf "FP(...)" - | Fs _ -> dprintf "FS" - | FS _ -> dprintf "FS" - - | FX _ -> dprintf "FX()" - - diff --git a/cil/src/cil.mli b/cil/src/cil.mli deleted file mode 100644 index 31c4e65..0000000 --- a/cil/src/cil.mli +++ /dev/null @@ -1,2455 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* - * CIL: An intermediate language for analyzing C programs. - * - * George Necula - * - *) - -(** CIL API Documentation. An html version of this document can be found at - * http://manju.cs.berkeley.edu/cil. *) - -(** Call this function to perform some initialization. Call if after you have - * set {!Cil.msvcMode}. *) -val initCIL: unit -> unit - - -(** This are the CIL version numbers. A CIL version is a number of the form - * M.m.r (major, minor and release) *) -val cilVersion: string -val cilVersionMajor: int -val cilVersionMinor: int -val cilVersionRevision: int - -(** This module defines the abstract syntax of CIL. It also provides utility - * functions for traversing the CIL data structures, and pretty-printing - * them. The parser for both the GCC and MSVC front-ends can be invoked as - * [Frontc.parse: string -> unit ->] {!Cil.file}. This function must be given - * the name of a preprocessed C file and will return the top-level data - * structure that describes a whole source file. By default the parsing and - * elaboration into CIL is done as for GCC source. If you want to use MSVC - * source you must set the {!Cil.msvcMode} to [true] and must also invoke the - * function [Frontc.setMSVCMode: unit -> unit]. *) - - -(** {b The Abstract Syntax of CIL} *) - - -(** The top-level representation of a CIL source file (and the result of the - * parsing and elaboration). Its main contents is the list of global - * declarations and definitions. You can iterate over the globals in a - * {!Cil.file} using the following iterators: {!Cil.mapGlobals}, - * {!Cil.iterGlobals} and {!Cil.foldGlobals}. You can also use the - * {!Cil.dummyFile} when you need a {!Cil.file} as a placeholder. For each - * global item CIL stores the source location where it appears (using the - * type {!Cil.location}) *) - -type file = - { mutable fileName: string; (** The complete file name *) - mutable globals: global list; (** List of globals as they will appear - in the printed file *) - mutable globinit: fundec option; - (** An optional global initializer function. This is a function where - * you can put stuff that must be executed before the program is - * started. This function, is conceptually at the end of the file, - * although it is not part of the globals list. Use {!Cil.getGlobInit} - * to create/get one. *) - mutable globinitcalled: bool; - (** Whether the global initialization function is called in main. This - * should always be false if there is no global initializer. When you - * create a global initialization CIL will try to insert code in main - * to call it. This will not happen if your file does not contain a - * function called "main" *) - } -(** Top-level representation of a C source file *) - -and comment = location * string - -(** {b Globals}. The main type for representing global declarations and - * definitions. A list of these form a CIL file. The order of globals in the - * file is generally important. *) - -(** A global declaration or definition *) -and global = - | GType of typeinfo * location - (** A typedef. All uses of type names (through the [TNamed] constructor) - must be preceded in the file by a definition of the name. The string - is the defined name and always not-empty. *) - - | GCompTag of compinfo * location - (** Defines a struct/union tag with some fields. There must be one of - these for each struct/union tag that you use (through the [TComp] - constructor) since this is the only context in which the fields are - printed. Consequently nested structure tag definitions must be - broken into individual definitions with the innermost structure - defined first. *) - - | GCompTagDecl of compinfo * location - (** Declares a struct/union tag. Use as a forward declaration. This is - * printed without the fields. *) - - | GEnumTag of enuminfo * location - (** Declares an enumeration tag with some fields. There must be one of - these for each enumeration tag that you use (through the [TEnum] - constructor) since this is the only context in which the items are - printed. *) - - | GEnumTagDecl of enuminfo * location - (** Declares an enumeration tag. Use as a forward declaration. This is - * printed without the items. *) - - | GVarDecl of varinfo * location - (** A variable declaration (not a definition). If the variable has a - function type then this is a prototype. There can be several - declarations and at most one definition for a given variable. If both - forms appear then they must share the same varinfo structure. A - prototype shares the varinfo with the fundec of the definition. Either - has storage Extern or there must be a definition in this file *) - - | GVar of varinfo * initinfo * location - (** A variable definition. Can have an initializer. The initializer is - * updateable so that you can change it without requiring to recreate - * the list of globals. There can be at most one definition for a - * variable in an entire program. Cannot have storage Extern or function - * type. *) - - | GFun of fundec * location - (** A function definition. *) - - | GAsm of string * location (** Global asm statement. These ones - can contain only a template *) - | GPragma of attribute * location (** Pragmas at top level. Use the same - syntax as attributes *) - | GText of string (** Some text (printed verbatim) at - top level. E.g., this way you can - put comments in the output. *) - -(** {b Types}. A C type is represented in CIL using the type {!Cil.typ}. - * Among types we differentiate the integral types (with different kinds - * denoting the sign and precision), floating point types, enumeration types, - * array and pointer types, and function types. Every type is associated with - * a list of attributes, which are always kept in sorted order. Use - * {!Cil.addAttribute} and {!Cil.addAttributes} to construct list of - * attributes. If you want to inspect a type, you should use - * {!Cil.unrollType} or {!Cil.unrollTypeDeep} to see through the uses of - * named types. *) -(** CIL is configured at build-time with the sizes and alignments of the - * underlying compiler (GCC or MSVC). CIL contains functions that can compute - * the size of a type (in bits) {!Cil.bitsSizeOf}, the alignment of a type - * (in bytes) {!Cil.alignOf_int}, and can convert an offset into a start and - * width (both in bits) using the function {!Cil.bitsOffset}. At the moment - * these functions do not take into account the [packed] attributes and - * pragmas. *) - -and typ = - TVoid of attributes (** Void type. Also predefined as {!Cil.voidType} *) - | TInt of ikind * attributes - (** An integer type. The kind specifies the sign and width. Several - * useful variants are predefined as {!Cil.intType}, {!Cil.uintType}, - * {!Cil.longType}, {!Cil.charType}. *) - - - | TFloat of fkind * attributes - (** A floating-point type. The kind specifies the precision. You can - * also use the predefined constant {!Cil.doubleType}. *) - - | TPtr of typ * attributes - (** Pointer type. Several useful variants are predefined as - * {!Cil.charPtrType}, {!Cil.charConstPtrType} (pointer to a - * constant character), {!Cil.voidPtrType}, - * {!Cil.intPtrType} *) - - | TArray of typ * exp option * attributes - (** Array type. It indicates the base type and the array length. *) - - | TFun of typ * (string * typ * attributes) list option * bool * attributes - (** Function type. Indicates the type of the result, the name, type - * and name attributes of the formal arguments ([None] if no - * arguments were specified, as in a function whose definition or - * prototype we have not seen; [Some \[\]] means void). Use - * {!Cil.argsToList} to obtain a list of arguments. The boolean - * indicates if it is a variable-argument function. If this is the - * type of a varinfo for which we have a function declaration then - * the information for the formals must match that in the - * function's sformals. Use {!Cil.setFormals}, or - * {!Cil.setFunctionType}, or {!Cil.makeFormalVar} for this - * purpose. *) - - | TNamed of typeinfo * attributes - (* The use of a named type. Each such type name must be preceded - * in the file by a [GType] global. This is printed as just the - * type name. The actual referred type is not printed here and is - * carried only to simplify processing. To see through a sequence - * of named type references, use {!Cil.unrollType} or - * {!Cil.unrollTypeDeep}. The attributes are in addition to those - * given when the type name was defined. *) - - | TComp of compinfo * attributes -(** The most delicate issue for C types is that recursion that is possible by - * using structures and pointers. To address this issue we have a more - * complex representation for structured types (struct and union). Each such - * type is represented using the {!Cil.compinfo} type. For each composite - * type the {!Cil.compinfo} structure must be declared at top level using - * [GCompTag] and all references to it must share the same copy of the - * structure. The attributes given are those pertaining to this use of the - * type and are in addition to the attributes that were given at the - * definition of the type and which are stored in the {!Cil.compinfo}. *) - - | TEnum of enuminfo * attributes - (** A reference to an enumeration type. All such references must - share the enuminfo among them and with a [GEnumTag] global that - precedes all uses. The attributes refer to this use of the - enumeration and are in addition to the attributes of the - enumeration itself, which are stored inside the enuminfo *) - - - | TBuiltin_va_list of attributes - (** This is the same as the gcc's type with the same name *) - -(** - There are a number of functions for querying the kind of a type. These are - {!Cil.isIntegralType}, - {!Cil.isArithmeticType}, - {!Cil.isPointerType}, - {!Cil.isFunctionType}, - {!Cil.isArrayType}. - - There are two easy ways to scan a type. First, you can use the -{!Cil.existsType} to return a boolean answer about a type. This function -is controlled by a user-provided function that is queried for each type that is -used to construct the current type. The function can specify whether to -terminate the scan with a boolean result or to continue the scan for the -nested types. - - The other method for scanning types is provided by the visitor interface (see - {!Cil.cilVisitor}). - - If you want to compare types (or to use them as hash-values) then you should -use instead type signatures (represented as {!Cil.typsig}). These -contain the same information as types but canonicalized such that simple Ocaml -structural equality will tell whether two types are equal. Use -{!Cil.typeSig} to compute the signature of a type. If you want to ignore -certain type attributes then use {!Cil.typeSigWithAttrs}. - -*) - - -(** Various kinds of integers *) -and ikind = - IChar (** [char] *) - | ISChar (** [signed char] *) - | IUChar (** [unsigned char] *) - | IInt (** [int] *) - | IUInt (** [unsigned int] *) - | IShort (** [short] *) - | IUShort (** [unsigned short] *) - | ILong (** [long] *) - | IULong (** [unsigned long] *) - | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) - | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft - Visual C) *) - -(** Various kinds of floating-point numbers*) -and fkind = - FFloat (** [float] *) - | FDouble (** [double] *) - | FLongDouble (** [long double] *) - - -(** {b Attributes.} *) - -and attribute = Attr of string * attrparam list -(** An attribute has a name and some optional parameters. The name should not - * start or end with underscore. When CIL parses attribute names it will - * strip leading and ending underscores (to ensure that the multitude of GCC - * attributes such as const, __const and __const__ all mean the same thing.) *) - -(** Attributes are lists sorted by the attribute name. Use the functions - * {!Cil.addAttribute} and {!Cil.addAttributes} to insert attributes in an - * attribute list and maintain the sortedness. *) -and attributes = attribute list - -(** The type of parameters of attributes *) -and attrparam = - | AInt of int (** An integer constant *) - | AStr of string (** A string constant *) - | ACons of string * attrparam list (** Constructed attributes. These - are printed [foo(a1,a2,...,an)]. - The list of parameters can be - empty and in that case the - parentheses are not printed. *) - | ASizeOf of typ (** A way to talk about types *) - | ASizeOfE of attrparam - | ASizeOfS of typsig (** Replacement for ASizeOf in type - signatures. Only used for - attributes inside typsigs.*) - | AAlignOf of typ - | AAlignOfE of attrparam - | AAlignOfS of typsig - | AUnOp of unop * attrparam - | ABinOp of binop * attrparam * attrparam - | ADot of attrparam * string (** a.foo **) - -(** {b Structures.} The {!Cil.compinfo} describes the definition of a - * structure or union type. Each such {!Cil.compinfo} must be defined at the - * top-level using the [GCompTag] constructor and must be shared by all - * references to this type (using either the [TComp] type constructor or from - * the definition of the fields. - - If all you need is to scan the definition of each - * composite type once, you can do that by scanning all top-level [GCompTag]. - - * Constructing a {!Cil.compinfo} can be tricky since it must contain fields - * that might refer to the host {!Cil.compinfo} and furthermore the type of - * the field might need to refer to the {!Cil.compinfo} for recursive types. - * Use the {!Cil.mkCompInfo} function to create a {!Cil.compinfo}. You can - * easily fetch the {!Cil.fieldinfo} for a given field in a structure with - * {!Cil.getCompField}. *) - -(** The definition of a structure or union type. Use {!Cil.mkCompInfo} to - * make one and use {!Cil.copyCompInfo} to copy one (this ensures that a new - * key is assigned and that the fields have the right pointers to parents.). *) -and compinfo = { - mutable cstruct: bool; - (** True if struct, False if union *) - mutable cname: string; - (** The name. Always non-empty. Use {!Cil.compFullName} to get the full - * name of a comp (along with the struct or union) *) - mutable ckey: int; - (** A unique integer. This is assigned by {!Cil.mkCompInfo} using a - * global variable in the Cil module. Thus two identical structs in two - * different files might have different keys. Use {!Cil.copyCompInfo} to - * copy structures so that a new key is assigned. *) - mutable cfields: fieldinfo list; - (** Information about the fields. Notice that each fieldinfo has a - * pointer back to the host compinfo. This means that you should not - * share fieldinfo's between two compinfo's *) - mutable cattr: attributes; - (** The attributes that are defined at the same time as the composite - * type. These attributes can be supplemented individually at each - * reference to this [compinfo] using the [TComp] type constructor. *) - mutable cdefined: bool; - (** This boolean flag can be used to distinguish between structures - that have not been defined and those that have been defined but have - no fields (such things are allowed in gcc). *) - mutable creferenced: bool; - (** True if used. Initially set to false. *) - } - -(** {b Structure fields.} The {!Cil.fieldinfo} structure is used to describe - * a structure or union field. Fields, just like variables, can have - * attributes associated with the field itself or associated with the type of - * the field (stored along with the type of the field). *) - -(** Information about a struct/union field *) -and fieldinfo = { - mutable fcomp: compinfo; - (** The host structure that contains this field. There can be only one - * [compinfo] that contains the field. *) - mutable fname: string; - (** The name of the field. Might be the value of {!Cil.missingFieldName} - * in which case it must be a bitfield and is not printed and it does not - * participate in initialization *) - mutable ftype: typ; - (** The type *) - mutable fbitfield: int option; - (** If a bitfield then ftype should be an integer type and the width of - * the bitfield must be 0 or a positive integer smaller or equal to the - * width of the integer type. A field of width 0 is used in C to control - * the alignment of fields. *) - mutable fattr: attributes; - (** The attributes for this field (not for its type) *) - mutable floc: location; - (** The location where this field is defined *) -} - - - -(** {b Enumerations.} Information about an enumeration. This is shared by all - * references to an enumeration. Make sure you have a [GEnumTag] for each of - * of these. *) - -(** Information about an enumeration *) -and enuminfo = { - mutable ename: string; - (** The name. Always non-empty. *) - mutable eitems: (string * exp * location) list; - (** Items with names and values. This list should be non-empty. The item - * values must be compile-time constants. *) - mutable eattr: attributes; - (** The attributes that are defined at the same time as the enumeration - * type. These attributes can be supplemented individually at each - * reference to this [enuminfo] using the [TEnum] type constructor. *) - mutable ereferenced: bool; - (** True if used. Initially set to false*) -} - -(** {b Enumerations.} Information about an enumeration. This is shared by all - * references to an enumeration. Make sure you have a [GEnumTag] for each of - * of these. *) - -(** Information about a defined type *) -and typeinfo = { - mutable tname: string; - (** The name. Can be empty only in a [GType] when introducing a composite - * or enumeration tag. If empty cannot be referred to from the file *) - mutable ttype: typ; - (** The actual type. This includes the attributes that were present in - * the typedef *) - mutable treferenced: bool; - (** True if used. Initially set to false*) -} - -(** {b Variables.} - Each local or global variable is represented by a unique {!Cil.varinfo} -structure. A global {!Cil.varinfo} can be introduced with the [GVarDecl] or -[GVar] or [GFun] globals. A local varinfo can be introduced as part of a -function definition {!Cil.fundec}. - - All references to a given global or local variable must refer to the same -copy of the [varinfo]. Each [varinfo] has a globally unique identifier that -can be used to index maps and hashtables (the name can also be used for this -purpose, except for locals from different functions). This identifier is -constructor using a global counter. - - It is very important that you construct [varinfo] structures using only one - of the following functions: -- {!Cil.makeGlobalVar} : to make a global variable -- {!Cil.makeTempVar} : to make a temporary local variable whose name -will be generated so that to avoid conflict with other locals. -- {!Cil.makeLocalVar} : like {!Cil.makeTempVar} but you can specify the -exact name to be used. -- {!Cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name -and a new unique identifier - - A [varinfo] is also used in a function type to denote the list of formals. - -*) - -(** Information about a variable. *) -and varinfo = { - mutable vname: string; - (** The name of the variable. Cannot be empty. It is primarily your - * responsibility to ensure the uniqueness of a variable name. For local - * variables {!Cil.makeTempVar} helps you ensure that the name is unique. - *) - - mutable vtype: typ; - (** The declared type of the variable. *) - - mutable vattr: attributes; - (** A list of attributes associated with the variable.*) - mutable vstorage: storage; - (** The storage-class *) - - mutable vglob: bool; - (** True if this is a global variable*) - - mutable vinline: bool; - (** Whether this varinfo is for an inline function. *) - - mutable vdecl: location; - (** Location of variable declaration. *) - - mutable vid: int; - (** A unique integer identifier. This field will be - * set for you if you use one of the {!Cil.makeFormalVar}, - * {!Cil.makeLocalVar}, {!Cil.makeTempVar}, {!Cil.makeGlobalVar}, or - * {!Cil.copyVarinfo}. *) - - mutable vaddrof: bool; - (** True if the address of this variable is taken. CIL will set these - * flags when it parses C, but you should make sure to set the flag - * whenever your transformation create [AddrOf] expression. *) - - mutable vreferenced: bool; - (** True if this variable is ever referenced. This is computed by - * [removeUnusedVars]. It is safe to just initialize this to False *) -} - -(** Storage-class information *) -and storage = - NoStorage (** The default storage. Nothing is printed *) - | Static - | Register - | Extern - - -(** {b Expressions.} The CIL expression language contains only the side-effect free expressions of -C. They are represented as the type {!Cil.exp}. There are several -interesting aspects of CIL expressions: - - Integer and floating point constants can carry their textual representation. -This way the integer 15 can be printed as 0xF if that is how it occurred in the -source. - - CIL uses 64 bits to represent the integer constants and also stores the width -of the integer type. Care must be taken to ensure that the constant is -representable with the given width. Use the functions {!Cil.kinteger}, -{!Cil.kinteger64} and {!Cil.integer} to construct constant -expressions. CIL predefines the constants {!Cil.zero}, -{!Cil.one} and {!Cil.mone} (for -1). - - Use the functions {!Cil.isConstant} and {!Cil.isInteger} to test if -an expression is a constant and a constant integer respectively. - - CIL keeps the type of all unary and binary expressions. You can think of that -type qualifying the operator. Furthermore there are different operators for -arithmetic and comparisons on arithmetic types and on pointers. - - Another unusual aspect of CIL is that the implicit conversion between an -expression of array type and one of pointer type is made explicit, using the -[StartOf] expression constructor (which is not printed). If you apply the -[AddrOf}]constructor to an lvalue of type [T] then you will be getting an -expression of type [TPtr(T)]. - - You can find the type of an expression with {!Cil.typeOf}. - - You can perform constant folding on expressions using the function -{!Cil.constFold}. -*) - -(** Expressions (Side-effect free)*) -and exp = - Const of constant (** Constant *) - | Lval of lval (** Lvalue *) - | SizeOf of typ - (** sizeof(). Has [unsigned int] type (ISO 6.5.3.4). This is not - * turned into a constant because some transformations might want to - * change types *) - - | SizeOfE of exp - (** sizeof() *) - - | SizeOfStr of string - (** sizeof(string_literal). We separate this case out because this is the - * only instance in which a string literal should not be treated as - * having type pointer to character. *) - - | AlignOf of typ - (** This corresponds to the GCC __alignof_. Has [unsigned int] type *) - | AlignOfE of exp - - - | UnOp of unop * exp * typ - (** Unary operation. Includes the type of the result. *) - - | BinOp of binop * exp * exp * typ - (** Binary operation. Includes the type of the result. The arithmetic - * conversions are made explicit for the arguments. *) - - | CastE of typ * exp - (** Use {!Cil.mkCast} to make casts. *) - - | AddrOf of lval - (** Always use {!Cil.mkAddrOf} to construct one of these. Apply to an - * lvalue of type [T] yields an expression of type [TPtr(T)] *) - - | StartOf of lval - (** Conversion from an array to a pointer to the beginning of the array. - * Given an lval of type [TArray(T)] produces an expression of type - * [TPtr(T)]. In C this operation is implicit, the [StartOf] operator is - * not printed. We have it in CIL because it makes the typing rules - * simpler. *) - -(** {b Constants.} *) - -(** Literal constants *) -and constant = - | CInt64 of int64 * ikind * string option - (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the - * textual representation, if available. (This allows us to print a - * constant as, for example, 0xF instead of 15.) Use {!Cil.integer} or - * {!Cil.kinteger} to create these. Watch out for integers that cannot be - * represented on 64 bits. OCAML does not give Overflow exceptions. *) - | CStr of string - (* String constant. The escape characters inside the string have been - * already interpreted. This constant has pointer to character type! The - * only case when you would like a string literal to have an array type - * is when it is an argument to sizeof. In that case you should use - * SizeOfStr. *) - | CWStr of int64 list - (* Wide character string constant. Note that the local interpretation - * of such a literal depends on {!Cil.wcharType} and {!Cil.wcharKind}. - * Such a constant has type pointer to {!Cil.wcharType}. The - * escape characters in the string have not been "interpreted" in - * the sense that L"A\xabcd" remains "A\xabcd" rather than being - * represented as the wide character list with two elements: 65 and - * 43981. That "interpretation" depends on the underlying wide - * character type. *) - | CChr of char - (** Character constant. This has type int, so use charConstToInt - * to read the value in case sign-extension is needed. *) - | CReal of float * fkind * string option - (** Floating point constant. Give the fkind (see ISO 6.4.4.2) and also - * the textual representation, if available. *) - | CEnum of exp * string * enuminfo - (** An enumeration constant with the given value, name, from the given - * enuminfo. This is used only if {!Cil.lowerConstants} is true - * (default). Use {!Cil.constFoldVisitor} to replace these with integer - * constants. *) - -(** Unary operators *) -and unop = - Neg (** Unary minus *) - | BNot (** Bitwise complement (~) *) - | LNot (** Logical Not (!) *) - -(** Binary operations *) -and binop = - PlusA (** arithmetic + *) - | PlusPI (** pointer + integer *) - | IndexPI (** pointer + integer but only when - * it arises from an expression - * [e\[i\]] when [e] is a pointer and - * not an array. This is semantically - * the same as PlusPI but CCured uses - * this as a hint that the integer is - * probably positive. *) - | MinusA (** arithmetic - *) - | MinusPI (** pointer - integer *) - | MinusPP (** pointer - pointer *) - | Mult (** * *) - | Div (** / *) - | Mod (** % *) - | Shiftlt (** shift left *) - | Shiftrt (** shift right *) - - | Lt (** < (arithmetic comparison) *) - | Gt (** > (arithmetic comparison) *) - | Le (** <= (arithmetic comparison) *) - | Ge (** > (arithmetic comparison) *) - | Eq (** == (arithmetic comparison) *) - | Ne (** != (arithmetic comparison) *) - | BAnd (** bitwise and *) - | BXor (** exclusive-or *) - | BOr (** inclusive-or *) - - | LAnd (** logical and. Unlike other - * expressions this one does not - * always evaluate both operands. If - * you want to use these, you must - * set {!Cil.useLogicalOperators}. *) - | LOr (** logical or. Unlike other - * expressions this one does not - * always evaluate both operands. If - * you want to use these, you must - * set {!Cil.useLogicalOperators}. *) - -(** {b Lvalues.} Lvalues are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator. -In C the syntax for lvalues is not always a good indication of the meaning -of the lvalue. For example the C value -{v -a[0][1][2] - v} - might involve 1, 2 or 3 memory reads when used in an expression context, -depending on the declared type of the variable [a]. If [a] has type [int -\[4\]\[4\]\[4\]] then we have one memory read from somewhere inside the area -that stores the array [a]. On the other hand if [a] has type [int ***] then -the expression really means [* ( * ( * (a + 0) + 1) + 2)], in which case it is -clear that it involves three separate memory operations. - -An lvalue denotes the contents of a range of memory addresses. This range -is denoted as a host object along with an offset within the object. The -host object can be of two kinds: a local or global variable, or an object -whose address is in a pointer expression. We distinguish the two cases so -that we can tell quickly whether we are accessing some component of a -variable directly or we are accessing a memory location through a pointer. -To make it easy to -tell what an lvalue means CIL represents lvalues as a host object and an -offset (see {!Cil.lval}). The host object (represented as -{!Cil.lhost}) can be a local or global variable or can be the object -pointed-to by a pointer expression. The offset (represented as -{!Cil.offset}) is a sequence of field or array index designators. - - Both the typing rules and the meaning of an lvalue is very precisely -specified in CIL. - - The following are a few useful function for operating on lvalues: -- {!Cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure -that certain equivalent forms of lvalues are canonized. -For example, [*&x = x]. -- {!Cil.typeOfLval} - the type of an lvalue -- {!Cil.typeOffset} - the type of an offset, given the type of the -host. -- {!Cil.addOffset} and {!Cil.addOffsetLval} - extend sequences -of offsets. -- {!Cil.removeOffset} and {!Cil.removeOffsetLval} - shrink sequences -of offsets. - -The following equivalences hold {v -Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off -Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off -AddrOf (Mem a, NoOffset) = a - v} - -*) -(** An lvalue *) -and lval = - lhost * offset - -(** The host part of an {!Cil.lval}. *) -and lhost = - | Var of varinfo - (** The host is a variable. *) - - | Mem of exp - (** The host is an object of type [T] when the expression has pointer - * [TPtr(T)]. *) - - -(** The offset part of an {!Cil.lval}. Each offset can be applied to certain - * kinds of lvalues and its effect is that it advances the starting address - * of the lvalue and changes the denoted type, essentially focusing to some - * smaller lvalue that is contained in the original one. *) -and offset = - | NoOffset (** No offset. Can be applied to any lvalue and does - * not change either the starting address or the type. - * This is used when the lval consists of just a host - * or as a terminator in a list of other kinds of - * offsets. *) - - | Field of fieldinfo * offset - (** A field offset. Can be applied only to an lvalue - * that denotes a structure or a union that contains - * the mentioned field. This advances the offset to the - * beginning of the mentioned field and changes the - * type to the type of the mentioned field. *) - - | Index of exp * offset - (** An array index offset. Can be applied only to an - * lvalue that denotes an array. This advances the - * starting address of the lval to the beginning of the - * mentioned array element and changes the denoted type - * to be the type of the array element *) - - -(** {b Initializers.} -A special kind of expressions are those that can appear as initializers for -global variables (initialization of local variables is turned into -assignments). The initializers are represented as type {!Cil.init}. You -can create initializers with {!Cil.makeZeroInit} and you can conveniently -scan compound initializers them with {!Cil.foldLeftCompound} or with {!Cil.foldLeftCompoundAll}. -*) -(** Initializers for global variables. *) -and init = - | SingleInit of exp (** A single initializer *) - | CompoundInit of typ * (offset * init) list - (** Used only for initializers of structures, unions and arrays. The - * offsets are all of the form [Field(f, NoOffset)] or [Index(i, - * NoOffset)] and specify the field or the index being initialized. For - * structures all fields must have an initializer (except the unnamed - * bitfields), in the proper order. This is necessary since the offsets - * are not printed. For unions there must be exactly one initializer. If - * the initializer is not for the first field then a field designator is - * printed, so you better be on GCC since MSVC does not understand this. - * For arrays, however, we allow you to give only a prefix of the - * initializers. You can scan an initializer list with - * {!Cil.foldLeftCompound} or with {!Cil.foldLeftCompoundAll}. *) - - -(** We want to be able to update an initializer in a global variable, so we - * define it as a mutable field *) -and initinfo = { - mutable init : init option; - } - -(** {b Function definitions.} -A function definition is always introduced with a [GFun] constructor at the -top level. All the information about the function is stored into a -{!Cil.fundec}. Some of the information (e.g. its name, type, -storage, attributes) is stored as a {!Cil.varinfo} that is a field of the -[fundec]. To refer to the function from the expression language you must use -the [varinfo]. - - The function definition contains, in addition to the body, a list of all the -local variables and separately a list of the formals. Both kind of variables -can be referred to in the body of the function. The formals must also be shared -with the formals that appear in the function type. For that reason, to -manipulate formals you should use the provided functions -{!Cil.makeFormalVar} and {!Cil.setFormals} and {!Cil.makeFormalVar}. -*) -(** Function definitions. *) -and fundec = - { mutable svar: varinfo; - (** Holds the name and type as a variable, so we can refer to it - * easily from the program. All references to this function either - * in a function call or in a prototype must point to the same - * [varinfo]. *) - mutable sformals: varinfo list; - (** Formals. These must be in the same order and with the same - * information as the formal information in the type of the function. - * Use {!Cil.setFormals} or - * {!Cil.setFunctionType} or {!Cil.makeFormalVar} - * to set these formals and ensure that they - * are reflected in the function type. Do not make copies of these - * because the body refers to them. *) - mutable slocals: varinfo list; - (** Locals. Does NOT include the sformals. Do not make copies of - * these because the body refers to them. *) - mutable smaxid: int; (** Max local id. Starts at 0. Used for - * creating the names of new temporary - * variables. Updated by - * {!Cil.makeLocalVar} and - * {!Cil.makeTempVar}. You can also use - * {!Cil.setMaxId} to set it after you - * have added the formals and locals. *) - mutable sbody: block; (** The function body. *) - mutable smaxstmtid: int option; (** max id of a (reachable) statement - * in this function, if we have - * computed it. range = 0 ... - * (smaxstmtid-1). This is computed by - * {!Cil.computeCFGInfo}. *) - mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} - * this field is set to contain all - * statements in the function *) - } - - -(** A block is a sequence of statements with the control falling through from - one element to the next *) -and block = - { mutable battrs: attributes; (** Attributes for the block *) - mutable bstmts: stmt list; (** The statements comprising the block*) - } - - -(** {b Statements}. -CIL statements are the structural elements that make the CFG. They are -represented using the type {!Cil.stmt}. Every -statement has a (possibly empty) list of labels. The -{!Cil.stmtkind} field of a statement indicates what kind of statement it -is. - - Use {!Cil.mkStmt} to make a statement and the fill-in the fields. - -CIL also comes with support for control-flow graphs. The [sid] field in -[stmt] can be used to give unique numbers to statements, and the [succs] -and [preds] fields can be used to maintain a list of successors and -predecessors for every statement. The CFG information is not computed by -default. Instead you must explicitly use the functions -{!Cil.prepareCFG} and {!Cil.computeCFGInfo} to do it. - -*) -(** Statements. *) -and stmt = { - mutable labels: label list; - (** Whether the statement starts with some labels, case statements or - * default statements. *) - - mutable skind: stmtkind; - (** The kind of statement *) - - mutable sid: int; - (** A number (>= 0) that is unique in a function. Filled in only after - * the CFG is computed. *) - mutable succs: stmt list; - (** The successor statements. They can always be computed from the skind - * and the context in which this statement appears. Filled in only after - * the CFG is computed. *) - mutable preds: stmt list; - (** The inverse of the succs function. *) - } - -(** Labels *) -and label = - Label of string * location * bool - (** A real label. If the bool is "true", the label is from the - * input source program. If the bool is "false", the label was - * created by CIL or some other transformation *) - | Case of exp * location (** A case statement. This expression - * is lowered into a constant if - * {!Cil.lowerConstants} is set to - * true. *) - | Default of location (** A default statement *) - - - -(** The various kinds of control-flow statements statements *) -and stmtkind = - | Instr of instr list - (** A group of instructions that do not contain control flow. Control - * implicitly falls through. *) - - | Return of exp option * location - (** The return statement. This is a leaf in the CFG. *) - - | Goto of stmt ref * location - (** A goto statement. Appears from actual goto's in the code or from - * goto's that have been inserted during elaboration. The reference - * points to the statement that is the target of the Goto. This means that - * you have to update the reference whenever you replace the target - * statement. The target statement MUST have at least a label. *) - - | Break of location - (** A break to the end of the nearest enclosing loop or Switch *) - - | Continue of location - (** A continue to the start of the nearest enclosing loop *) - | If of exp * block * block * location - (** A conditional. Two successors, the "then" and the "else" branches. - * Both branches fall-through to the successor of the If statement. *) - - | Switch of exp * block * (stmt list) * location - (** A switch statement. The statements that implement the cases can be - * reached through the provided list. For each such target you can find - * among its labels what cases it implements. The statements that - * implement the cases are somewhere within the provided [block]. *) - -(* - | Loop of block * location * (stmt option) * (stmt option) - (** A [while(1)] loop. The termination test is implemented in the body of - * a loop using a [Break] statement. If prepareCFG has been called, - * the first stmt option will point to the stmt containing the continue - * label for this loop and the second will point to the stmt containing - * the break label for this loop. *) -*) - - | While of exp * block * location - (** A [while] loop. *) - - | DoWhile of exp * block * location - (** A [do...while] loop. *) - - | For of block * exp * block * block * location - (** A [for] loop. *) - - | Block of block - (** Just a block of statements. Use it as a way to keep some block - * attributes local *) - - (** On MSVC we support structured exception handling. This is what you - * might expect. Control can get into the finally block either from the - * end of the body block, or if an exception is thrown. *) - | TryFinally of block * block * location - - (** On MSVC we support structured exception handling. The try/except - * statement is a bit tricky: - [__try { blk } - __except (e) { - handler - }] - - The argument to __except must be an expression. However, we keep a - list of instructions AND an expression in case you need to make - function calls. We'll print those as a comma expression. The control - can get to the __except expression only if an exception is thrown. - After that, depending on the value of the expression the control - goes to the handler, propagates the exception, or retries the - exception !!! - *) - | TryExcept of block * (instr list * exp) * block * location - - -(** {b Instructions}. - An instruction {!Cil.instr} is a statement that has no local -(intraprocedural) control flow. It can be either an assignment, -function call, or an inline assembly instruction. *) - -(** Instructions. *) -and instr = - Set of lval * exp * location - (** An assignment. The type of the expression is guaranteed to be the same - * with that of the lvalue *) - | Call of lval option * exp * exp list * location - (** A function call with the (optional) result placed in an lval. It is - * possible that the returned type of the function is not identical to - * that of the lvalue. In that case a cast is printed. The type of the - * actual arguments are identical to those of the declared formals. The - * number of arguments is the same as that of the declared formals, except - * for vararg functions. This construct is also used to encode a call to - * "__builtin_va_arg". In this case the second argument (which should be a - * type T) is encoded SizeOf(T) *) - - | Asm of attributes * (* Really only const and volatile can appear - * here *) - string list * (* templates (CR-separated) *) - (string * lval) list * (* outputs must be lvals with - * constraints. I would like these - * to be actually variables, but I - * run into some trouble with ASMs - * in the Linux sources *) - (string * exp) list * (* inputs with constraints *) - string list * (* register clobbers *) - location - (** There are for storing inline assembly. They follow the GCC - * specification: -{v - asm [volatile] ("...template..." "..template.." - : "c1" (o1), "c2" (o2), ..., "cN" (oN) - : "d1" (i1), "d2" (i2), ..., "dM" (iM) - : "r1", "r2", ..., "nL" ); - v} - -where the parts are - - - [volatile] (optional): when present, the assembler instruction - cannot be removed, moved, or otherwise optimized - - template: a sequence of strings, with %0, %1, %2, etc. in the string to - refer to the input and output expressions. I think they're numbered - consecutively, but the docs don't specify. Each string is printed on - a separate line. This is the only part that is present for MSVC inline - assembly. - - "ci" (oi): pairs of constraint-string and output-lval; the - constraint specifies that the register used must have some - property, like being a floating-point register; the constraint - string for outputs also has "=" to indicate it is written, or - "+" to indicate it is both read and written; 'oi' is the - name of a C lvalue (probably a variable name) to be used as - the output destination - - "dj" (ij): pairs of constraint and input expression; the constraint - is similar to the "ci"s. the 'ij' is an arbitrary C expression - to be loaded into the corresponding register - - "rk": registers to be regarded as "clobbered" by the instruction; - "memory" may be specified for arbitrary memory effects - -an example (from gcc manual): -{v - asm volatile ("movc3 %0,%1,%2" - : /* no outputs */ - : "g" (from), "g" (to), "g" (count) - : "r0", "r1", "r2", "r3", "r4", "r5"); - v} -*) - -(** Describes a location in a source file. *) -and location = { - line: int; (** The line number. -1 means "do not know" *) - file: string; (** The name of the source file*) - byte: int; (** The byte position in the source file *) -} - - -(** Type signatures. Two types are identical iff they have identical - * signatures. These contain the same information as types but canonicalized. - * For example, two function types that are identical except for the name of - * the formal arguments are given the same signature. Also, [TNamed] - * constructors are unrolled. *) -and typsig = - TSArray of typsig * int64 option * attribute list - | TSPtr of typsig * attribute list - | TSComp of bool * string * attribute list - | TSFun of typsig * typsig list * bool * attribute list - | TSEnum of string * attribute list - | TSBase of typ - - - -(** {b Lowering Options} *) - -val lowerConstants: bool ref - (** Do lower constants (default true) *) - -val insertImplicitCasts: bool ref - (** Do insert implicit casts (default true) *) - -(** To be able to add/remove features easily, each feature should be package - * as an interface with the following interface. These features should be *) -type featureDescr = { - fd_enabled: bool ref; - (** The enable flag. Set to default value *) - - fd_name: string; - (** This is used to construct an option "--doxxx" and "--dontxxx" that - * enable and disable the feature *) - - fd_description: string; - (* A longer name that can be used to document the new options *) - - fd_extraopt: (string * Arg.spec * string) list; - (** Additional command line options *) - - fd_doit: (file -> unit); - (** This performs the transformation *) - - fd_post_check: bool; - (* Whether to perform a CIL consistency checking after this stage, if - * checking is enabled (--check is passed to cilly). Set this to true if - * your feature makes any changes for the program. *) -} - -(** Comparison function for locations. - ** Compares first by filename, then line, then byte *) -val compareLoc: location -> location -> int - -(** {b Values for manipulating globals} *) - -(** Make an empty function *) -val emptyFunction: string -> fundec - -(** Update the formals of a [fundec] and make sure that the function type - has the same information. Will copy the name as well into the type. *) -val setFormals: fundec -> varinfo list -> unit - -(** Set the types of arguments and results as given by the function type - * passed as the second argument. Will not copy the names from the function - * type to the formals *) -val setFunctionType: fundec -> typ -> unit - - -(** Set the type of the function and make formal arguments for them *) -val setFunctionTypeMakeFormals: fundec -> typ -> unit - -(** Update the smaxid after you have populated with locals and formals - * (unless you constructed those using {!Cil.makeLocalVar} or - * {!Cil.makeTempVar}. *) -val setMaxId: fundec -> unit - -(** A dummy function declaration handy when you need one as a placeholder. It - * contains inside a dummy varinfo. *) -val dummyFunDec: fundec - -(** A dummy file *) -val dummyFile: file - -(** Write a {!Cil.file} in binary form to the filesystem. The file can be - * read back in later using {!Cil.loadBinaryFile}, possibly saving parsing - * time. The second argument is the name of the file that should be - * created. *) -val saveBinaryFile : file -> string -> unit - -(** Write a {!Cil.file} in binary form to the filesystem. The file can be - * read back in later using {!Cil.loadBinaryFile}, possibly saving parsing - * time. Does not close the channel. *) -val saveBinaryFileChannel : file -> out_channel -> unit - -(** Read a {!Cil.file} in binary form from the filesystem. The first - * argument is the name of a file previously created by - * {!Cil.saveBinaryFile}. *) -val loadBinaryFile : string -> file - -(** Get the global initializer and create one if it does not already exist. - * When it creates a global initializer it attempts to place a call to it in - * the main function named by the optional argument (default "main") *) -val getGlobInit: ?main_name:string -> file -> fundec - -(** Iterate over all globals, including the global initializer *) -val iterGlobals: file -> (global -> unit) -> unit - -(** Fold over all globals, including the global initializer *) -val foldGlobals: file -> ('a -> global -> 'a) -> 'a -> 'a - -(** Map over all globals, including the global initializer and change things - in place *) -val mapGlobals: file -> (global -> global) -> unit - -val new_sid : unit -> int - -(** Prepare a function for CFG information computation by - * {!Cil.computeCFGInfo}. This function converts all [Break], [Switch], - * [Default] and [Continue] {!Cil.stmtkind}s and {!Cil.label}s into [If]s - * and [Goto]s, giving the function body a very CFG-like character. This - * function modifies its argument in place. *) -val prepareCFG: fundec -> unit - -(** Compute the CFG information for all statements in a fundec and return a - * list of the statements. The input fundec cannot have [Break], [Switch], - * [Default], or [Continue] {!Cil.stmtkind}s or {!Cil.label}s. Use - * {!Cil.prepareCFG} to transform them away. The second argument should - * be [true] if you wish a global statement number, [false] if you wish a - * local (per-function) statement numbering. The list of statements is set - * in the sallstmts field of a fundec. - * - * NOTE: unless you want the simpler control-flow graph provided by - * prepareCFG, or you need the function's smaxstmtid and sallstmt fields - * filled in, we recommend you use {!Cfg.computeFileCFG} instead of this - * function to compute control-flow information. - * {!Cfg.computeFileCFG} is newer and will handle switch, break, and - * continue correctly.*) -val computeCFGInfo: fundec -> bool -> unit - - -(** Create a deep copy of a function. There should be no sharing between the - * copy and the original function *) -val copyFunction: fundec -> string -> fundec - - -(** CIL keeps the types at the beginning of the file and the variables at the - * end of the file. This function will take a global and add it to the - * corresponding stack. Its operation is actually more complicated because if - * the global declares a type that contains references to variables (e.g. in - * sizeof in an array length) then it will also add declarations for the - * variables to the types stack *) -val pushGlobal: global -> types: global list ref - -> variables: global list ref -> unit - -(** An empty statement. Used in pretty printing *) -val invalidStmt: stmt - -(** A list of the GCC built-in functions. Maps the name to the result and - * argument types, and whether it is vararg *) -val gccBuiltins: (string, typ * typ list * bool) Hashtbl.t - - -(** A list of the MSVC built-in functions. Maps the name to the result and - * argument types, and whether it is vararg *) -val msvcBuiltins: (string, typ * typ list * bool) Hashtbl.t - -(** {b Values for manipulating initializers} *) - - -(** Make a initializer for zero-ing a data type *) -val makeZeroInit: typ -> init - - -(** Fold over the list of initializers in a Compound. [doinit] is called on - * every present initializer, even if it is of compound type. In the case of - * arrays there might be missing zero-initializers at the end of the list. - * These are not scanned. This is much like [List.fold_left] except we also - * pass the type of the initializer *) -val foldLeftCompound: - doinit: (offset -> init -> typ -> 'a -> 'a) -> - ct: typ -> - initl: (offset * init) list -> - acc: 'a -> 'a - - -(** Fold over the list of initializers in a Compound, like - * {!Cil.foldLeftCompound} but in the case of an array it scans even missing - * zero initializers at the end of the array *) -val foldLeftCompoundAll: - doinit: (offset -> init -> typ -> 'a -> 'a) -> - ct: typ -> - initl: (offset * init) list -> - acc: 'a -> 'a - - - -(** {b Values for manipulating types} *) - -(** void *) -val voidType: typ - -(* is the given type "void"? *) -val isVoidType: typ -> bool - -(* is the given type "void *"? *) -val isVoidPtrType: typ -> bool - -(** int *) -val intType: typ - -(** unsigned int *) -val uintType: typ - -(** long *) -val longType: typ - -(** unsigned long *) -val ulongType: typ - -(** char *) -val charType: typ - -(** char * *) -val charPtrType: typ - -(** wchar_t (depends on architecture) and is set when you call - * {!Cil.initCIL}. *) -val wcharKind: ikind ref -val wcharType: typ ref - -(** char const * *) -val charConstPtrType: typ - -(** void * *) -val voidPtrType: typ - -(** int * *) -val intPtrType: typ - -(** unsigned int * *) -val uintPtrType: typ - -(** double *) -val doubleType: typ - -(* An unsigned integer type that fits pointers. Depends on {!Cil.msvcMode} - * and is set when you call {!Cil.initCIL}. *) -val upointType: typ ref - -(* An unsigned integer type that is the type of sizeof. Depends on - * {!Cil.msvcMode} and is set when you call {!Cil.initCIL}. *) -val typeOfSizeOf: typ ref - -(** Returns true if and only if the given integer type is signed. *) -val isSigned: ikind -> bool - - -(** Creates a a (potentially recursive) composite type. The arguments are: - * (1) a boolean indicating whether it is a struct or a union, (2) the name - * (always non-empty), (3) a function that when given a representation of the - * structure type constructs the type of the fields recursive type (the first - * argument is only useful when some fields need to refer to the type of the - * structure itself), and (4) a list of attributes to be associated with the - * composite type. The resulting compinfo has the field "cdefined" only if - * the list of fields is non-empty. *) -val mkCompInfo: bool -> (* whether it is a struct or a union *) - string -> (* name of the composite type; cannot be empty *) - (compinfo -> - (string * typ * int option * attributes * location) list) -> - (* a function that when given a forward - representation of the structure type constructs the type of - the fields. The function can ignore this argument if not - constructing a recursive type. *) - attributes -> compinfo - -(** Makes a shallow copy of a {!Cil.compinfo} changing the name and the key.*) -val copyCompInfo: compinfo -> string -> compinfo - -(** This is a constant used as the name of an unnamed bitfield. These fields - do not participate in initialization and their name is not printed. *) -val missingFieldName: string - -(** Get the full name of a comp *) -val compFullName: compinfo -> string - -(** Returns true if this is a complete type. - This means that sizeof(t) makes sense. - Incomplete types are not yet defined - structures and empty arrays. *) -val isCompleteType: typ -> bool - -(** Unroll a type until it exposes a non - * [TNamed]. Will collect all attributes appearing in [TNamed]!!! *) -val unrollType: typ -> typ - -(** Unroll all the TNamed in a type (even under type constructors such as - * [TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp] - * types. Will collect all attributes *) -val unrollTypeDeep: typ -> typ - -(** Separate out the storage-modifier name attributes *) -val separateStorageModifiers: attribute list -> attribute list * attribute list - -(** True if the argument is an integral type (i.e. integer or enum) *) -val isIntegralType: typ -> bool - -(** True if the argument is an arithmetic type (i.e. integer, enum or - floating point *) -val isArithmeticType: typ -> bool - -(**True if the argument is a pointer type *) -val isPointerType: typ -> bool - -(** True if the argument is a function type *) -val isFunctionType: typ -> bool - -(** Obtain the argument list ([] if None) *) -val argsToList: (string * typ * attributes) list option - -> (string * typ * attributes) list - -(** True if the argument is an array type *) -val isArrayType: typ -> bool - -(** Raised when {!Cil.lenOfArray} fails either because the length is [None] - * or because it is a non-constant expression *) -exception LenOfArray - -(** Call to compute the array length as present in the array type, to an - * integer. Raises {!Cil.LenOfArray} if not able to compute the length, such - * as when there is no length or the length is not a constant. *) -val lenOfArray: exp option -> int - -(** Return a named fieldinfo in compinfo, or raise Not_found *) -val getCompField: compinfo -> string -> fieldinfo - - -(** A datatype to be used in conjunction with [existsType] *) -type existsAction = - ExistsTrue (* We have found it *) - | ExistsFalse (* Stop processing this branch *) - | ExistsMaybe (* This node is not what we are - * looking for but maybe its - * successors are *) - -(** Scans a type by applying the function on all elements. - When the function returns ExistsTrue, the scan stops with - true. When the function returns ExistsFalse then the current branch is not - scanned anymore. Care is taken to - apply the function only once on each composite type, thus avoiding - circularity. When the function returns ExistsMaybe then the types that - construct the current type are scanned (e.g. the base type for TPtr and - TArray, the type of fields for a TComp, etc). *) -val existsType: (typ -> existsAction) -> typ -> bool - - -(** Given a function type split it into return type, - * arguments, is_vararg and attributes. An error is raised if the type is not - * a function type *) -val splitFunctionType: - typ -> typ * (string * typ * attributes) list option * bool * attributes -(** Same as {!Cil.splitFunctionType} but takes a varinfo. Prints a nicer - * error message if the varinfo is not for a function *) -val splitFunctionTypeVI: - varinfo -> typ * (string * typ * attributes) list option * bool * attributes - - -(** {b Type signatures} *) - -(** Type signatures. Two types are identical iff they have identical - * signatures. These contain the same information as types but canonicalized. - * For example, two function types that are identical except for the name of - * the formal arguments are given the same signature. Also, [TNamed] - * constructors are unrolled. You shoud use [Util.equals] to compare type - * signatures because they might still contain circular structures (through - * attributes, and sizeof) *) - -(** Print a type signature *) -val d_typsig: unit -> typsig -> Pretty.doc - -(** Compute a type signature *) -val typeSig: typ -> typsig - -(** Like {!Cil.typeSig} but customize the incorporation of attributes. - Use ~ignoreSign:true to convert all signed integer types to unsigned, - so that signed and unsigned will compare the same. *) -val typeSigWithAttrs: ?ignoreSign:bool -> (attributes -> attributes) -> typ -> typsig - -(** Replace the attributes of a signature (only at top level) *) -val setTypeSigAttrs: attributes -> typsig -> typsig - -(** Get the top-level attributes of a signature *) -val typeSigAttrs: typsig -> attributes - -(*********************************************************) -(** LVALUES *) - -(** Make a varinfo. Use this (rarely) to make a raw varinfo. Use other - * functions to make locals ({!Cil.makeLocalVar} or {!Cil.makeFormalVar} or - * {!Cil.makeTempVar}) and globals ({!Cil.makeGlobalVar}). Note that this - * function will assign a new identifier. The first argument specifies - * whether the varinfo is for a global. *) -val makeVarinfo: bool -> string -> typ -> varinfo - -(** Make a formal variable for a function. Insert it in both the sformals - and the type of the function. You can optionally specify where to insert - this one. If where = "^" then it is inserted first. If where = "$" then - it is inserted last. Otherwise where must be the name of a formal after - which to insert this. By default it is inserted at the end. *) -val makeFormalVar: fundec -> ?where:string -> string -> typ -> varinfo - -(** Make a local variable and add it to a function's slocals (only if insert = - true, which is the default). Make sure you know what you are doing if you - set insert=false. *) -val makeLocalVar: fundec -> ?insert:bool -> string -> typ -> varinfo - -(** Make a temporary variable and add it to a function's slocals. The name of - the temporary variable will be generated based on the given name hint so - that to avoid conflicts with other locals. *) -val makeTempVar: fundec -> ?name: string -> typ -> varinfo - - -(** Make a global variable. Your responsibility to make sure that the name - is unique *) -val makeGlobalVar: string -> typ -> varinfo - -(** Make a shallow copy of a [varinfo] and assign a new identifier *) -val copyVarinfo: varinfo -> string -> varinfo - - -(** Generate a new variable ID. This will be different than any variable ID - * that is generated by {!Cil.makeLocalVar} and friends *) -val newVID: unit -> int - -(** Add an offset at the end of an lvalue. Make sure the type of the lvalue - * and the offset are compatible. *) -val addOffsetLval: offset -> lval -> lval - -(** [addOffset o1 o2] adds [o1] to the end of [o2]. *) -val addOffset: offset -> offset -> offset - -(** Remove ONE offset from the end of an lvalue. Returns the lvalue with the - * trimmed offset and the final offset. If the final offset is [NoOffset] - * then the original [lval] did not have an offset. *) -val removeOffsetLval: lval -> lval * offset - -(** Remove ONE offset from the end of an offset sequence. Returns the - * trimmed offset and the final offset. If the final offset is [NoOffset] - * then the original [lval] did not have an offset. *) -val removeOffset: offset -> offset * offset - -(** Compute the type of an lvalue *) -val typeOfLval: lval -> typ - -(** Compute the type of an offset from a base type *) -val typeOffset: typ -> offset -> typ - - -(*******************************************************) -(** {b Values for manipulating expressions} *) - - -(* Construct integer constants *) - -(** 0 *) -val zero: exp - -(** 1 *) -val one: exp - -(** -1 *) -val mone: exp - - -(** Construct an integer of a given kind, using OCaml's int64 type. If needed - * it will truncate the integer to be within the representable range for the - * given kind. *) -val kinteger64: ikind -> int64 -> exp - -(** Construct an integer of a given kind. Converts the integer to int64 and - * then uses kinteger64. This might truncate the value if you use a kind - * that cannot represent the given integer. This can only happen for one of - * the Char or Short kinds *) -val kinteger: ikind -> int -> exp - -(** Construct an integer of kind IInt. You can use this always since the - OCaml integers are 31 bits and are guaranteed to fit in an IInt *) -val integer: int -> exp - - -(** True if the given expression is a (possibly cast'ed) - character or an integer constant *) -val isInteger: exp -> int64 option - -(** True if the expression is a compile-time constant *) -val isConstant: exp -> bool - -(** True if the given expression is a (possibly cast'ed) integer or character - constant with value zero *) -val isZero: exp -> bool - -(** Given the character c in a (CChr c), sign-extend it to 32 bits. - (This is the official way of interpreting character constants, according to - ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) - Returns CInt64(sign-extened c, IInt, None) *) -val charConstToInt: char -> constant - -(** Do constant folding on an expression. If the first argument is true then - will also compute compiler-dependent expressions such as sizeof *) -val constFold: bool -> exp -> exp - -(** Do constant folding on a binary operation. The bulk of the work done by - [constFold] is done here. If the first argument is true then - will also compute compiler-dependent expressions such as sizeof *) -val constFoldBinOp: bool -> binop -> exp -> exp -> typ -> exp - -(** Increment an expression. Can be arithmetic or pointer type *) -val increm: exp -> int -> exp - - -(** Makes an lvalue out of a given variable *) -val var: varinfo -> lval - -(** Make an AddrOf. Given an lvalue of type T will give back an expression of - type ptr(T). It optimizes somewhat expressions like "& v" and "& v[0]" *) -val mkAddrOf: lval -> exp - - -(** Like mkAddrOf except if the type of lval is an array then it uses - StartOf. This is the right operation for getting a pointer to the start - of the storage denoted by lval. *) -val mkAddrOrStartOf: lval -> exp - -(** Make a Mem, while optimizing AddrOf. The type of the addr must be - TPtr(t) and the type of the resulting lval is t. Note that in CIL the - implicit conversion between an array and the pointer to the first - element does not apply. You must do the conversion yourself using - StartOf *) -val mkMem: addr:exp -> off:offset -> lval - -(** Make an expression that is a string constant (of pointer type) *) -val mkString: string -> exp - -(** Construct a cast when having the old type of the expression. If the new - * type is the same as the old type, then no cast is added. *) -val mkCastT: e:exp -> oldt:typ -> newt:typ -> exp - -(** Like {!Cil.mkCastT} but uses typeOf to get [oldt] *) -val mkCast: e:exp -> newt:typ -> exp - -(** Removes casts from this expression, but ignores casts within - other expression constructs. So we delete the (A) and (B) casts from - "(A)(B)(x + (C)y)", but leave the (C) cast. *) -val stripCasts: exp -> exp - -(** Compute the type of an expression *) -val typeOf: exp -> typ - -(** Convert a string representing a C integer literal to an expression. - * Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL *) -val parseInt: string -> exp - - -(**********************************************) -(** {b Values for manipulating statements} *) - -(** Construct a statement, given its kind. Initialize the [sid] field to -1, - and [labels], [succs] and [preds] to the empty list *) -val mkStmt: stmtkind -> stmt - -(** Construct a block with no attributes, given a list of statements *) -val mkBlock: stmt list -> block - -(** Construct a statement consisting of just one instruction *) -val mkStmtOneInstr: instr -> stmt - -(** Try to compress statements so as to get maximal basic blocks *) -(* use this instead of List.@ because you get fewer basic blocks *) -val compactStmts: stmt list -> stmt list - -(** Returns an empty statement (of kind [Instr]) *) -val mkEmptyStmt: unit -> stmt - -(** A instr to serve as a placeholder *) -val dummyInstr: instr - -(** A statement consisting of just [dummyInstr] *) -val dummyStmt: stmt - -(** Make a while loop. Can contain Break or Continue *) -val mkWhile: guard:exp -> body:stmt list -> stmt list - -(** Make a for loop for(i=start; i first:exp -> stopat:exp -> incr:exp - -> body:stmt list -> stmt list - -(** Make a for loop for(start; guard; next) \{ ... \}. The body can - contain Break but not Continue !!! *) -val mkFor: start:stmt list -> guard:exp -> next: stmt list -> - body: stmt list -> stmt list - - - -(**************************************************) -(** {b Values for manipulating attributes} *) - -(** Various classes of attributes *) -type attributeClass = - AttrName of bool - (** Attribute of a name. If argument is true and we are on MSVC then - the attribute is printed using __declspec as part of the storage - specifier *) - | AttrFunType of bool - (** Attribute of a function type. If argument is true and we are on - MSVC then the attribute is printed just before the function name *) - | AttrType (** Attribute of a type *) - -(** This table contains the mapping of predefined attributes to classes. - Extend this table with more attributes as you need. This table is used to - determine how to associate attributes with names or types *) -val attributeHash: (string, attributeClass) Hashtbl.t - -(** Partition the attributes into classes:name attributes, function type, - and type attributes *) -val partitionAttributes: default:attributeClass -> - attributes -> attribute list * (* AttrName *) - attribute list * (* AttrFunType *) - attribute list (* AttrType *) - -(** Add an attribute. Maintains the attributes in sorted order of the second - argument *) -val addAttribute: attribute -> attributes -> attributes - -(** Add a list of attributes. Maintains the attributes in sorted order. The - second argument must be sorted, but not necessarily the first *) -val addAttributes: attribute list -> attributes -> attributes - -(** Remove all attributes with the given name. Maintains the attributes in - sorted order. *) -val dropAttribute: string -> attributes -> attributes - -(** Remove all attributes with names appearing in the string list. - * Maintains the attributes in sorted order *) -val dropAttributes: string list -> attributes -> attributes - -(** Retains attributes with the given name *) -val filterAttributes: string -> attributes -> attributes - -(** True if the named attribute appears in the attribute list. The list of - attributes must be sorted. *) -val hasAttribute: string -> attributes -> bool - -(** Returns all the attributes contained in a type. This requires a traversal - of the type structure, in case of composite, enumeration and named types *) -val typeAttrs: typ -> attribute list - -val setTypeAttrs: typ -> attributes -> typ (* Resets the attributes *) - - -(** Add some attributes to a type *) -val typeAddAttributes: attribute list -> typ -> typ - -(** Remove all attributes with the given names from a type. Note that this - does not remove attributes from typedef and tag definitions, just from - their uses *) -val typeRemoveAttributes: string list -> typ -> typ - - -(****************** - ****************** VISITOR - ******************) -(** {b The visitor} *) - -(** Different visiting actions. 'a will be instantiated with [exp], [instr], - etc. *) -type 'a visitAction = - SkipChildren (** Do not visit the children. Return - the node as it is. *) - | DoChildren (** Continue with the children of this - node. Rebuild the node on return - if any of the children changes - (use == test) *) - | ChangeTo of 'a (** Replace the expression with the - given one *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire - exp is replaced by the first - parameter. Then continue with - the children. On return rebuild - the node if any of the children - has changed and then apply the - function on the node *) - - - -(** A visitor interface for traversing CIL trees. Create instantiations of - * this type by specializing the class {!Cil.nopCilVisitor}. Each of the - * specialized visiting functions can also call the [queueInstr] to specify - * that some instructions should be inserted before the current instruction - * or statement. Use syntax like [self#queueInstr] to call a method - * associated with the current object. *) -class type cilVisitor = object - method vvdec: varinfo -> varinfo visitAction - (** Invoked for each variable declaration. The subtrees to be traversed - * are those corresponding to the type and attributes of the variable. - * Note that variable declarations are all the [GVar], [GVarDecl], [GFun], - * all the [varinfo] in formals of function types, and the formals and - * locals for function definitions. This means that the list of formals - * in a function definition will be traversed twice, once as part of the - * function type and second as part of the formals in a function - * definition. *) - - method vvrbl: varinfo -> varinfo visitAction - (** Invoked on each variable use. Here only the [SkipChildren] and - * [ChangeTo] actions make sense since there are no subtrees. Note that - * the type and attributes of the variable are not traversed for a - * variable use *) - - method vexpr: exp -> exp visitAction - (** Invoked on each expression occurrence. The subtrees are the - * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the - * variable use. *) - - method vlval: lval -> lval visitAction - (** Invoked on each lvalue occurrence *) - - method voffs: offset -> offset visitAction - (** Invoked on each offset occurrence that is *not* as part - * of an initializer list specification, i.e. in an lval or - * recursively inside an offset. *) - - method vinitoffs: offset -> offset visitAction - (** Invoked on each offset appearing in the list of a - * CompoundInit initializer. *) - - method vinst: instr -> instr list visitAction - (** Invoked on each instruction occurrence. The [ChangeTo] action can - * replace this instruction with a list of instructions *) - - method vstmt: stmt -> stmt visitAction - (** Control-flow statement. The default [DoChildren] action does not - * create a new statement when the components change. Instead it updates - * the contents of the original statement. This is done to preserve the - * sharing with [Goto] and [Case] statements that point to the original - * statement. If you use the [ChangeTo] action then you should take care - * of preserving that sharing yourself. *) - - method vblock: block -> block visitAction (** Block. *) - method vfunc: fundec -> fundec visitAction (** Function definition. - Replaced in place. *) - method vglob: global -> global list visitAction (** Global (vars, types, - etc.) *) - method vinit: init -> init visitAction (** Initializers for globals *) - method vtype: typ -> typ visitAction (** Use of some type. Note - * that for structure/union - * and enumeration types the - * definition of the - * composite type is not - * visited. Use [vglob] to - * visit it. *) - method vattr: attribute -> attribute list visitAction - (** Attribute. Each attribute can be replaced by a list *) - method vattrparam: attrparam -> attrparam visitAction - (** Attribute parameters. *) - - (** Add here instructions while visiting to queue them to preceede the - * current statement or instruction being processed. Use this method only - * when you are visiting an expression that is inside a function body, or - * a statement, because otherwise there will no place for the visitor to - * place your instructions. *) - method queueInstr: instr list -> unit - - (** Gets the queue of instructions and resets the queue. This is done - * automatically for you when you visit statments. *) - method unqueueInstr: unit -> instr list - -end - -(** Default Visitor. Traverses the CIL tree without modifying anything *) -class nopCilVisitor: cilVisitor - -(* other cil constructs *) - -(** Visit a file. This will will re-cons all globals TWICE (so that it is - * tail-recursive). Use {!Cil.visitCilFileSameGlobals} if your visitor will - * not change the list of globals. *) -val visitCilFile: cilVisitor -> file -> unit - -(** A visitor for the whole file that does not change the globals (but maybe - * changes things inside the globals). Use this function instead of - * {!Cil.visitCilFile} whenever appropriate because it is more efficient for - * long files. *) -val visitCilFileSameGlobals: cilVisitor -> file -> unit - -(** Visit a global *) -val visitCilGlobal: cilVisitor -> global -> global list - -(** Visit a function definition *) -val visitCilFunction: cilVisitor -> fundec -> fundec - -(* Visit an expression *) -val visitCilExpr: cilVisitor -> exp -> exp - -(** Visit an lvalue *) -val visitCilLval: cilVisitor -> lval -> lval - -(** Visit an lvalue or recursive offset *) -val visitCilOffset: cilVisitor -> offset -> offset - -(** Visit an initializer offset *) -val visitCilInitOffset: cilVisitor -> offset -> offset - -(** Visit an instruction *) -val visitCilInstr: cilVisitor -> instr -> instr list - -(** Visit a statement *) -val visitCilStmt: cilVisitor -> stmt -> stmt - -(** Visit a block *) -val visitCilBlock: cilVisitor -> block -> block - -(** Visit a type *) -val visitCilType: cilVisitor -> typ -> typ - -(** Visit a variable declaration *) -val visitCilVarDecl: cilVisitor -> varinfo -> varinfo - -(** Visit an initializer *) -val visitCilInit: cilVisitor -> init -> init - - -(** Visit a list of attributes *) -val visitCilAttributes: cilVisitor -> attribute list -> attribute list - -(* And some generic visitors. The above are built with these *) - - -(** {b Utility functions} *) - -(** Whether the pretty printer should print output for the MS VC compiler. - Default is GCC. After you set this function you should call {!Cil.initCIL}. *) -val msvcMode: bool ref - - -(** Whether to use the logical operands LAnd and LOr. By default, do not use - * them because they are unlike other expressions and do not evaluate both of - * their operands *) -val useLogicalOperators: bool ref - - -(** A visitor that does constant folding. Pass as argument whether you want - * machine specific simplifications to be done, or not. *) -val constFoldVisitor: bool -> cilVisitor - -(** Styles of printing line directives *) -type lineDirectiveStyle = - | LineComment - | LinePreprocessorInput - | LinePreprocessorOutput - -(** How to print line directives *) -val lineDirectiveStyle: lineDirectiveStyle option ref - -(** Whether we print something that will only be used as input to our own - * parser. In that case we are a bit more liberal in what we print *) -val print_CIL_Input: bool ref - -(** Whether to print the CIL as they are, without trying to be smart and - * print nicer code. Normally this is false, in which case the pretty - * printer will turn the while(1) loops of CIL into nicer loops, will not - * print empty "else" blocks, etc. These is one case howewer in which if you - * turn this on you will get code that does not compile: if you use varargs - * the __builtin_va_arg function will be printed in its internal form. *) -val printCilAsIs: bool ref - -(** The length used when wrapping output lines. Setting this variable to - * a large integer will prevent wrapping and make #line directives more - * accurate. - *) -val lineLength: int ref - -(** Return the string 's' if we're printing output for gcc, suppres - * it if we're printing for CIL to parse back in. the purpose is to - * hide things from gcc that it complains about, but still be able - * to do lossless transformations when CIL is the consumer *) -val forgcc: string -> string - -(** {b Debugging support} *) - -(** A reference to the current location. If you are careful to set this to - * the current location then you can use some built-in logging functions that - * will print the location. *) -val currentLoc: location ref - -(** A reference to the current global being visited *) -val currentGlobal: global ref - - -(** CIL has a fairly easy to use mechanism for printing error messages. This - * mechanism is built on top of the pretty-printer mechanism (see - * {!Pretty.doc}) and the error-message modules (see {!Errormsg.error}). - - Here is a typical example for printing a log message: {v -ignore (Errormsg.log "Expression %a is not positive (at %s:%i)\n" - d_exp e loc.file loc.line) - v} - - and here is an example of how you print a fatal error message that stop the -* execution: {v -Errormsg.s (Errormsg.bug "Why am I here?") - v} - - Notice that you can use C format strings with some extension. The most -useful extension is "%a" that means to consumer the next two argument from -the argument list and to apply the first to [unit] and then to the second -and to print the resulting {!Pretty.doc}. For each major type in CIL there is -a corresponding function that pretty-prints an element of that type: -*) - - -(** Pretty-print a location *) -val d_loc: unit -> location -> Pretty.doc - -(** Pretty-print the {!Cil.currentLoc} *) -val d_thisloc: unit -> Pretty.doc - -(** Pretty-print an integer of a given kind *) -val d_ikind: unit -> ikind -> Pretty.doc - -(** Pretty-print a floating-point kind *) -val d_fkind: unit -> fkind -> Pretty.doc - -(** Pretty-print storage-class information *) -val d_storage: unit -> storage -> Pretty.doc - -(** Pretty-print a constant *) -val d_const: unit -> constant -> Pretty.doc - - -val derefStarLevel: int -val indexLevel: int -val arrowLevel: int -val addrOfLevel: int -val additiveLevel: int -val comparativeLevel: int -val bitwiseLevel: int - -(** Parentheses level. An expression "a op b" is printed parenthesized if its - * parentheses level is >= that that of its context. Identifiers have the - * lowest level and weakly binding operators (e.g. |) have the largest level. - * The correctness criterion is that a smaller level MUST correspond to a - * stronger precedence! - *) -val getParenthLevel: exp -> int - -(** A printer interface for CIL trees. Create instantiations of - * this type by specializing the class {!Cil.defaultCilPrinterClass}. *) -class type cilPrinter = object - method pVDecl: unit -> varinfo -> Pretty.doc - (** Invoked for each variable declaration. Note that variable - * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] - * in formals of function types, and the formals and locals for function - * definitions. *) - - method pVar: varinfo -> Pretty.doc - (** Invoked on each variable use. *) - - method pLval: unit -> lval -> Pretty.doc - (** Invoked on each lvalue occurrence *) - - method pOffset: Pretty.doc -> offset -> Pretty.doc - (** Invoked on each offset occurrence. The second argument is the base. *) - - method pInstr: unit -> instr -> Pretty.doc - (** Invoked on each instruction occurrence. *) - - method pLabel: unit -> label -> Pretty.doc - (** Print a label. *) - - method pStmt: unit -> stmt -> Pretty.doc - (** Control-flow statement. This is used by - * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *) - - method dStmt: out_channel -> int -> stmt -> unit - (** Dump a control-flow statement to a file with a given indentation. - * This is used by {!Cil.dumpGlobal}. *) - - method dBlock: out_channel -> int -> block -> unit - (** Dump a control-flow block to a file with a given indentation. - * This is used by {!Cil.dumpGlobal}. *) - - method pBlock: unit -> block -> Pretty.doc - - method pBlock: unit -> block -> Pretty.doc - (** Print a block. *) - - method pGlobal: unit -> global -> Pretty.doc - (** Global (vars, types, etc.). This can be slow and is used only by - * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) - - method dGlobal: out_channel -> global -> unit - (** Dump a global to a file with a given indentation. This is used by - * {!Cil.dumpGlobal} *) - - method pFieldDecl: unit -> fieldinfo -> Pretty.doc - (** A field declaration *) - - method pType: Pretty.doc option -> unit -> typ -> Pretty.doc - (* Use of some type in some declaration. The first argument is used to print - * the declared element, or is None if we are just printing a type with no - * name being declared. Note that for structure/union and enumeration types - * the definition of the composite type is not visited. Use [vglob] to - * visit it. *) - - method pAttr: attribute -> Pretty.doc * bool - (** Attribute. Also return an indication whether this attribute must be - * printed inside the __attribute__ list or not. *) - - method pAttrParam: unit -> attrparam -> Pretty.doc - (** Attribute parameter *) - - method pAttrs: unit -> attributes -> Pretty.doc - (** Attribute lists *) - - method pLineDirective: ?forcefile:bool -> location -> Pretty.doc - (** Print a line-number. This is assumed to come always on an empty line. - * If the forcefile argument is present and is true then the file name - * will be printed always. Otherwise the file name is printed only if it - * is different from the last time time this function is called. The last - * file name is stored in a private field inside the cilPrinter object. *) - - method pStmtKind: stmt -> unit -> stmtkind -> Pretty.doc - (** Print a statement kind. The code to be printed is given in the - * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument - * records the statement which follows the one being printed; - * {!Cil.defaultCilPrinterClass} uses this information to prettify - * statement printing in certain special cases. *) - - method pExp: unit -> exp -> Pretty.doc - (** Print expressions *) - - method pInit: unit -> init -> Pretty.doc - (** Print initializers. This can be slow and is used by - * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) - - method dInit: out_channel -> int -> init -> unit - (** Dump a global to a file with a given indentation. This is used by - * {!Cil.dumpGlobal} *) -end - -class defaultCilPrinterClass: cilPrinter -val defaultCilPrinter: cilPrinter - -(** These are pretty-printers that will show you more details on the internal - * CIL representation, without trying hard to make it look like C *) -class plainCilPrinterClass: cilPrinter -val plainCilPrinter: cilPrinter - -(* zra: This is the pretty printer that Maincil will use. - by default it is set to defaultCilPrinter *) -val printerForMaincil: cilPrinter ref - -(* Top-level printing functions *) -(** Print a type given a pretty printer *) -val printType: cilPrinter -> unit -> typ -> Pretty.doc - -(** Print an expression given a pretty printer *) -val printExp: cilPrinter -> unit -> exp -> Pretty.doc - -(** Print an lvalue given a pretty printer *) -val printLval: cilPrinter -> unit -> lval -> Pretty.doc - -(** Print a global given a pretty printer *) -val printGlobal: cilPrinter -> unit -> global -> Pretty.doc - -(** Print an attribute given a pretty printer *) -val printAttr: cilPrinter -> unit -> attribute -> Pretty.doc - -(** Print a set of attributes given a pretty printer *) -val printAttrs: cilPrinter -> unit -> attributes -> Pretty.doc - -(** Print an instruction given a pretty printer *) -val printInstr: cilPrinter -> unit -> instr -> Pretty.doc - -(** Print a statement given a pretty printer. This can take very long - * (or even overflow the stack) for huge statements. Use {!Cil.dumpStmt} - * instead. *) -val printStmt: cilPrinter -> unit -> stmt -> Pretty.doc - -(** Print a block given a pretty printer. This can take very long - * (or even overflow the stack) for huge block. Use {!Cil.dumpBlock} - * instead. *) -val printBlock: cilPrinter -> unit -> block -> Pretty.doc - -(** Dump a statement to a file using a given indentation. Use this instead of - * {!Cil.printStmt} whenever possible. *) -val dumpStmt: cilPrinter -> out_channel -> int -> stmt -> unit - -(** Dump a block to a file using a given indentation. Use this instead of - * {!Cil.printBlock} whenever possible. *) -val dumpBlock: cilPrinter -> out_channel -> int -> block -> unit - -(** Print an initializer given a pretty printer. This can take very long - * (or even overflow the stack) for huge initializers. Use {!Cil.dumpInit} - * instead. *) -val printInit: cilPrinter -> unit -> init -> Pretty.doc - -(** Dump an initializer to a file using a given indentation. Use this instead of - * {!Cil.printInit} whenever possible. *) -val dumpInit: cilPrinter -> out_channel -> int -> init -> unit - -(** Pretty-print a type using {!Cil.defaultCilPrinter} *) -val d_type: unit -> typ -> Pretty.doc - -(** Pretty-print an expression using {!Cil.defaultCilPrinter} *) -val d_exp: unit -> exp -> Pretty.doc - -(** Pretty-print an lvalue using {!Cil.defaultCilPrinter} *) -val d_lval: unit -> lval -> Pretty.doc - -(** Pretty-print an offset using {!Cil.defaultCilPrinter}, given the pretty - * printing for the base. *) -val d_offset: Pretty.doc -> unit -> offset -> Pretty.doc - -(** Pretty-print an initializer using {!Cil.defaultCilPrinter}. This can be - * extremely slow (or even overflow the stack) for huge initializers. Use - * {!Cil.dumpInit} instead. *) -val d_init: unit -> init -> Pretty.doc - -(** Pretty-print a binary operator *) -val d_binop: unit -> binop -> Pretty.doc - -(** Pretty-print a unary operator *) -val d_unop: unit -> unop -> Pretty.doc - -(** Pretty-print an attribute using {!Cil.defaultCilPrinter} *) -val d_attr: unit -> attribute -> Pretty.doc - -(** Pretty-print an argument of an attribute using {!Cil.defaultCilPrinter} *) -val d_attrparam: unit -> attrparam -> Pretty.doc - -(** Pretty-print a list of attributes using {!Cil.defaultCilPrinter} *) -val d_attrlist: unit -> attributes -> Pretty.doc - -(** Pretty-print an instruction using {!Cil.defaultCilPrinter} *) -val d_instr: unit -> instr -> Pretty.doc - -(** Pretty-print a label using {!Cil.defaultCilPrinter} *) -val d_label: unit -> label -> Pretty.doc - -(** Pretty-print a statement using {!Cil.defaultCilPrinter}. This can be - * extremely slow (or even overflow the stack) for huge statements. Use - * {!Cil.dumpStmt} instead. *) -val d_stmt: unit -> stmt -> Pretty.doc - -(** Pretty-print a block using {!Cil.defaultCilPrinter}. This can be - * extremely slow (or even overflow the stack) for huge blocks. Use - * {!Cil.dumpBlock} instead. *) -val d_block: unit -> block -> Pretty.doc - -(** Pretty-print the internal representation of a global using - * {!Cil.defaultCilPrinter}. This can be extremely slow (or even overflow the - * stack) for huge globals (such as arrays with lots of initializers). Use - * {!Cil.dumpGlobal} instead. *) -val d_global: unit -> global -> Pretty.doc - - -(** Versions of the above pretty printers, that don't print #line directives *) -val dn_exp : unit -> exp -> Pretty.doc -val dn_lval : unit -> lval -> Pretty.doc -(* dn_offset is missing because it has a different interface *) -val dn_init : unit -> init -> Pretty.doc -val dn_type : unit -> typ -> Pretty.doc -val dn_global : unit -> global -> Pretty.doc -val dn_attrlist : unit -> attributes -> Pretty.doc -val dn_attr : unit -> attribute -> Pretty.doc -val dn_attrparam : unit -> attrparam -> Pretty.doc -val dn_stmt : unit -> stmt -> Pretty.doc -val dn_instr : unit -> instr -> Pretty.doc - - -(** Pretty-print a short description of the global. This is useful for error - * messages *) -val d_shortglobal: unit -> global -> Pretty.doc - -(** Pretty-print a global. Here you give the channel where the printout - * should be sent. *) -val dumpGlobal: cilPrinter -> out_channel -> global -> unit - -(** Pretty-print an entire file. Here you give the channel where the printout - * should be sent. *) -val dumpFile: cilPrinter -> out_channel -> string -> file -> unit - - -(* the following error message producing functions also print a location in - * the code. use {!Errormsg.bug} and {!Errormsg.unimp} if you do not want - * that *) - -(** Like {!Errormsg.bug} except that {!Cil.currentLoc} is also printed *) -val bug: ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Errormsg.unimp} except that {!Cil.currentLoc}is also printed *) -val unimp: ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Errormsg.error} except that {!Cil.currentLoc} is also printed *) -val error: ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Cil.error} except that it explicitly takes a location argument, - * instead of using the {!Cil.currentLoc} *) -val errorLoc: location -> ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Errormsg.warn} except that {!Cil.currentLoc} is also printed *) -val warn: ('a,unit,Pretty.doc) format -> 'a - - -(** Like {!Errormsg.warnOpt} except that {!Cil.currentLoc} is also printed. - * This warning is printed only of {!Errormsg.warnFlag} is set. *) -val warnOpt: ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context - is also printed *) -val warnContext: ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context is also - * printed. This warning is printed only of {!Errormsg.warnFlag} is set. *) -val warnContextOpt: ('a,unit,Pretty.doc) format -> 'a - -(** Like {!Cil.warn} except that it explicitly takes a location argument, - * instead of using the {!Cil.currentLoc} *) -val warnLoc: location -> ('a,unit,Pretty.doc) format -> 'a - -(** Sometimes you do not want to see the syntactic sugar that the above - * pretty-printing functions add. In that case you can use the following - * pretty-printing functions. But note that the output of these functions is - * not valid C *) - -(** Pretty-print the internal representation of an expression *) -val d_plainexp: unit -> exp -> Pretty.doc - -(** Pretty-print the internal representation of an integer *) -val d_plaininit: unit -> init -> Pretty.doc - -(** Pretty-print the internal representation of an lvalue *) -val d_plainlval: unit -> lval -> Pretty.doc - -(** Pretty-print the internal representation of an lvalue offset -val d_plainoffset: unit -> offset -> Pretty.doc *) - -(** Pretty-print the internal representation of a type *) -val d_plaintype: unit -> typ -> Pretty.doc - - - -(** {b ALPHA conversion} has been moved to the Alpha module. *) - - -(** Assign unique names to local variables. This might be necessary after you - * transformed the code and added or renamed some new variables. Names are - * not used by CIL internally, but once you print the file out the compiler - * downstream might be confused. You might - * have added a new global that happens to have the same name as a local in - * some function. Rename the local to ensure that there would never be - * confusioin. Or, viceversa, you might have added a local with a name that - * conflicts with a global *) -val uniqueVarNames: file -> unit - -(** {b Optimization Passes} *) - -(** A peephole optimizer that processes two adjacent statements and possibly - replaces them both. If some replacement happens, then the new statements - are themselves subject to optimization *) -val peepHole2: (instr * instr -> instr list option) -> stmt list -> unit - -(** Similar to [peepHole2] except that the optimization window consists of - one statement, not two *) -val peepHole1: (instr -> instr list option) -> stmt list -> unit - -(** {b Machine dependency} *) - - -(** Raised when one of the bitsSizeOf functions cannot compute the size of a - * type. This can happen because the type contains array-length expressions - * that we don't know how to compute or because it is a type whose size is - * not defined (e.g. TFun or an undefined compinfo). The string is an - * explanation of the error *) -exception SizeOfError of string * typ - -(** The size of a type, in bits. Trailing padding is added for structs and - * arrays. Raises {!Cil.SizeOfError} when it cannot compute the size. This - * function is architecture dependent, so you should only call this after you - * call {!Cil.initCIL}. Remember that on GCC sizeof(void) is 1! *) -val bitsSizeOf: typ -> int - -(* The size of a type, in bytes. Returns a constant expression or a "sizeof" - * expression if it cannot compute the size. This function is architecture - * dependent, so you should only call this after you call {!Cil.initCIL}. *) -val sizeOf: typ -> exp - -(** The minimum alignment (in bytes) for a type. This function is - * architecture dependent, so you should only call this after you call - * {!Cil.initCIL}. *) -val alignOf_int: typ -> int - -(** Give a type of a base and an offset, returns the number of bits from the - * base address and the width (also expressed in bits) for the subobject - * denoted by the offset. Raises {!Cil.SizeOfError} when it cannot compute - * the size. This function is architecture dependent, so you should only call - * this after you call {!Cil.initCIL}. *) -val bitsOffset: typ -> offset -> int * int - - -(** Whether "char" is unsigned. Set after you call {!Cil.initCIL} *) -val char_is_unsigned: bool ref - -(** Whether the machine is little endian. Set after you call {!Cil.initCIL} *) -val little_endian: bool ref - -(** Whether the compiler generates assembly labels by prepending "_" to the - identifier. That is, will function foo() have the label "foo", or "_foo"? - Set after you call {!Cil.initCIL} *) -val underscore_name: bool ref - -(** Represents a location that cannot be determined *) -val locUnknown: location - -(** Return the location of an instruction *) -val get_instrLoc: instr -> location - -(** Return the location of a global, or locUnknown *) -val get_globalLoc: global -> location - -(** Return the location of a statement, or locUnknown *) -val get_stmtLoc: stmtkind -> location - - -(** Generate an {!Cil.exp} to be used in case of errors. *) -val dExp: Pretty.doc -> exp - -(** Generate an {!Cil.instr} to be used in case of errors. *) -val dInstr: Pretty.doc -> location -> instr - -(** Generate a {!Cil.global} to be used in case of errors. *) -val dGlobal: Pretty.doc -> location -> global - -(** Like map but try not to make a copy of the list *) -val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list - -(** Like map but each call can return a list. Try not to make a copy of the - list *) -val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list - -(** sm: return true if the first is a prefix of the second string *) -val startsWith: string -> string -> bool - - -(** {b An Interpreter for constructing CIL constructs} *) - -(** The type of argument for the interpreter *) -type formatArg = - Fe of exp - | Feo of exp option (** For array lengths *) - | Fu of unop - | Fb of binop - | Fk of ikind - | FE of exp list (** For arguments in a function call *) - | Ff of (string * typ * attributes) (** For a formal argument *) - | FF of (string * typ * attributes) list (** For formal argument lists *) - | Fva of bool (** For the ellipsis in a function type *) - | Fv of varinfo - | Fl of lval - | Flo of lval option - - | Fo of offset - - | Fc of compinfo - | Fi of instr - | FI of instr list - | Ft of typ - | Fd of int - | Fg of string - | Fs of stmt - | FS of stmt list - | FA of attributes - - | Fp of attrparam - | FP of attrparam list - - | FX of string - - -(** Pretty-prints a format arg *) -val d_formatarg: unit -> formatArg -> Pretty.doc - -val lowerConstants: bool ref - (** Do lower constant expressions into constants (default true) *) diff --git a/cil/src/cillower.ml b/cil/src/cillower.ml deleted file mode 100755 index 61745bf..0000000 --- a/cil/src/cillower.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** A number of lowering passes over CIL *) -open Cil -open Pretty -module E = Errormsg - -(** Lower CEnum constants *) -class lowerEnumVisitorClass : cilVisitor = object (self) - inherit nopCilVisitor - - method vexpr (e: exp) = - match e with - Const (CEnum(v, s, ei)) -> - ChangeTo (visitCilExpr (self :>cilVisitor) v) - - | _ -> DoChildren - -end - -let lowerEnumVisitor = new lowerEnumVisitorClass diff --git a/cil/src/cillower.mli b/cil/src/cillower.mli deleted file mode 100755 index a62c9e3..0000000 --- a/cil/src/cillower.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** A number of lowering passes over CIL *) - -(** Replace enumeration constants with integer constants *) -val lowerEnumVisitor : Cil.cilVisitor diff --git a/cil/src/ciloptions.ml b/cil/src/ciloptions.ml deleted file mode 100755 index 9a2b4bd..0000000 --- a/cil/src/ciloptions.ml +++ /dev/null @@ -1,196 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -module E = Errormsg - -let setDebugFlag v name = - E.debugFlag := v; - if v then Pretty.flushOften := true - -type outfile = - { fname: string; - fchan: out_channel } - -let setTraceDepth n = - Pretty.printDepth := n - - - (* Processign of output file arguments *) -let openFile (what: string) (takeit: outfile -> unit) (fl: string) = - if !E.verboseFlag then - ignore (Printf.printf "Setting %s to %s\n" what fl); - (try takeit { fname = fl; - fchan = open_out fl } - with _ -> - raise (Arg.Bad ("Cannot open " ^ what ^ " file " ^ fl))) - - -let fileNames : string list ref = ref [] -let recordFile fname = - fileNames := fname :: (!fileNames) - - (* Parsing of files with additional names *) -let parseExtraFile (s: string) = - try - let sfile = open_in s in - while true do - let line = try input_line sfile with e -> (close_in sfile; raise e) in - let linelen = String.length line in - let rec scan (pos: int) (* next char to look at *) - (start: int) : unit (* start of the word, - or -1 if none *) = - if pos >= linelen then - if start >= 0 then - recordFile (String.sub line start (pos - start)) - else - () (* Just move on to the next line *) - else - let c = String.get line pos in - match c with - ' ' | '\n' | '\r' | '\t' -> - (* whitespace *) - if start >= 0 then begin - recordFile (String.sub line start (pos - start)); - end; - scan (pos + 1) (-1) - - | _ -> (* non-whitespace *) - if start >= 0 then - scan (pos + 1) start - else - scan (pos + 1) pos - in - scan 0 (-1) - done - with Sys_error _ -> E.s (E.error "Cannot find extra file: %s\n" s) - | End_of_file -> () - - -let options : (string * Arg.spec * string) list = - [ - (* General Options *) - "", Arg.Unit (fun () -> ()), "\n\t\tGeneral Options\n" ; - - "--version", Arg.Unit - (fun _ -> print_endline ("CIL version " ^ Cil.cilVersion ^ - "\nMore information at http://cil.sourceforge.net/\n"); - exit 0), - "output version information and exit"; - "--verbose", Arg.Unit (fun _ -> E.verboseFlag := true), - "Print lots of random stuff. This is passed on from cilly."; - "--warnall", Arg.Unit (fun _ -> E.warnFlag := true), "Show all warnings"; - "--debug", Arg.String (setDebugFlag true), - " turns on debugging flag xxx"; - "--nodebug", Arg.String (setDebugFlag false), - " turns off debugging flag xxx"; - - "--flush", Arg.Unit (fun _ -> Pretty.flushOften := true), - "Flush the output streams often (aids debugging)" ; - "--check", Arg.Unit (fun _ -> Cilutil.doCheck := true), - "Run a consistency check over the CIL after every operation."; - "--nocheck", Arg.Unit (fun _ -> Cilutil.doCheck := false), - "turns off consistency checking of CIL"; - "--noPrintLn", Arg.Unit (fun _ -> Cil.lineDirectiveStyle := None; - Cprint.printLn := false), - "Don't output #line directives in the output."; - "--commPrintLn", Arg.Unit (fun _ -> Cil.lineDirectiveStyle := Some Cil.LineComment; - Cprint.printLnComment := true), - "Print #line directives in the output, but put them in comments."; - "--stats", Arg.Unit (fun _ -> Cilutil.printStats := true), - "Print statistics about running times and memory usage."; - - - "--log", Arg.String (openFile "log" (fun oc -> E.logChannel := oc.fchan)), - "Set the name of the log file. By default stderr is used"; - - "--MSVC", Arg.Unit (fun _ -> Cil.msvcMode := true; - Frontc.setMSVCMode (); - if not Machdep.hasMSVC then - ignore (E.warn "Will work in MSVC mode but will be using machine-dependent parameters for GCC since you do not have the MSVC compiler installed\n") - ), "Enable MSVC compatibility. Default is GNU."; - - "--testcil", Arg.String (fun s -> Cilutil.testcil := s), - "test CIL using the given compiler"; - - "--ignore-merge-conflicts", - Arg.Unit (fun _ -> Mergecil.ignore_merge_conflicts := true), - "ignore merging conflicts"; - "--sliceGlobal", Arg.Unit (fun _ -> Cilutil.sliceGlobal := true), - "output is the slice of #pragma cilnoremove(sym) symbols"; - - (* sm: some more debugging options *) - "--tr", Arg.String Trace.traceAddMulti, - ": subsystem to show debug printfs for"; - "--pdepth", Arg.Int setTraceDepth, - ": set max print depth (default: 5)"; - - "--extrafiles", Arg.String parseExtraFile, - ": the name of a file that contains a list of additional files to process, separated by whitespace of newlines"; - - (* Lowering Options *) - "", Arg.Unit (fun () -> ()), "\n\t\tLowering Options\n" ; - - "--noLowerConstants", Arg.Unit (fun _ -> Cil.lowerConstants := false), - "do not lower constant expressions"; - - "--noInsertImplicitCasts", Arg.Unit (fun _ -> Cil.insertImplicitCasts := false), - "do not insert implicit casts"; - - "--forceRLArgEval", - Arg.Unit (fun n -> Cabs2cil.forceRLArgEval := true), - "Forces right to left evaluation of function arguments"; - "--nocil", Arg.Int (fun n -> Cabs2cil.nocil := n), - "Do not compile to CIL the global with the given index"; - "--disallowDuplication", Arg.Unit (fun n -> Cabs2cil.allowDuplication := false), - "Prevent small chunks of code from being duplicated"; - "--keepunused", Arg.Set Rmtmps.keepUnused, - "Do not remove the unused variables and types"; - "--rmUnusedInlines", Arg.Set Rmtmps.rmUnusedInlines, - "Delete any unused inline functions. This is the default in MSVC mode"; - - - - "", Arg.Unit (fun () -> ()), "\n\t\tOutput Options\n" ; - "--printCilAsIs", Arg.Unit (fun _ -> Cil.printCilAsIs := true), - "do not try to simplify the CIL when printing. Without this flag, CIL will attempt to produce prettier output by e.g. changing while(1) into more meaningful loops."; - "--noWrap", Arg.Unit (fun _ -> Cil.lineLength := 100000), - "do not wrap long lines when printing"; - - ] - diff --git a/cil/src/ciloptions.mli b/cil/src/ciloptions.mli deleted file mode 100755 index 13f65cf..0000000 --- a/cil/src/ciloptions.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(** The command-line options for CIL *) -val options : (string * Arg.spec * string) list - - -(** The list of file names *) -val fileNames : string list ref - -(** Adds the file to the start of fileNames *) -val recordFile: string -> unit diff --git a/cil/src/cilutil.ml b/cil/src/cilutil.ml deleted file mode 100644 index b9a4da9..0000000 --- a/cil/src/cilutil.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Keep here the globally-visible flags *) -let doCheck= ref false (* Whether to check CIL *) - -let logCalls = ref false (* Whether to produce a log with all the function - * calls made *) -let logWrites = ref false (* Whether to produce a log with all the mem - * writes made *) -let doPartial = ref false (* Whether to do partial evaluation and constant - * folding *) -let doSimpleMem = ref false (* reduce complex memory expressions so that - * they contain at most one lval *) -let doOneRet = ref false (* make a functions have at most one 'return' *) -let doStackGuard = ref false (* instrument function calls and returns to -maintain a separate stack for return addresses *) -let doHeapify = ref false (* move stack-allocated arrays to the heap *) -let makeCFG = ref false (* turn the input CIL file into something more like - * a CFG *) -let printStats = ref false - -(* when 'sliceGlobal' is set, then when 'rmtmps' runs, only globals*) -(* marked with #pragma cilnoremove(whatever) are kept; when used with *) -(* cilly.asm.exe, the effect is to slice the input on the noremove symbols *) -let sliceGlobal = ref false - - -let printStages = ref false - - -let doCxxPP = ref false - -let libDir = ref "" - -let dumpFCG = ref false -let testcil = ref "" - diff --git a/cil/src/escape.ml b/cil/src/escape.ml deleted file mode 100644 index 198c9e5..0000000 --- a/cil/src/escape.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* - * - * Copyright (c) 2003, - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(** OCaml types used to represent wide characters and strings *) -type wchar = int64 -type wstring = wchar list - - -let escape_char = function - | '\007' -> "\\a" - | '\b' -> "\\b" - | '\t' -> "\\t" - | '\n' -> "\\n" - | '\011' -> "\\v" - | '\012' -> "\\f" - | '\r' -> "\\r" - | '"' -> "\\\"" - | '\'' -> "\\'" - | '\\' -> "\\\\" - | ' ' .. '~' as printable -> String.make 1 printable - | unprintable -> Printf.sprintf "\\%03o" (Char.code unprintable) - -let escape_string str = - let length = String.length str in - let buffer = Buffer.create length in - for index = 0 to length - 1 do - Buffer.add_string buffer (escape_char (String.get str index)) - done; - Buffer.contents buffer - -(* a wide char represented as an int64 *) -let escape_wchar = - (* limit checks whether upper > probe *) - let limit upper probe = (Int64.to_float (Int64.sub upper probe)) > 0.5 in - let fits_byte = limit (Int64.of_int 0x100) in - let fits_octal_escape = limit (Int64.of_int 0o1000) in - let fits_universal_4 = limit (Int64.of_int 0x10000) in - let fits_universal_8 = limit (Int64.of_string "0x100000000") in - fun charcode -> - if fits_byte charcode then - escape_char (Char.chr (Int64.to_int charcode)) - else if fits_octal_escape charcode then - Printf.sprintf "\\%03Lo" charcode - else if fits_universal_4 charcode then - Printf.sprintf "\\u%04Lx" charcode - else if fits_universal_8 charcode then - Printf.sprintf "\\u%04Lx" charcode - else - invalid_arg "Cprint.escape_string_intlist" - -(* a wide string represented as a list of int64s *) -let escape_wstring (str : int64 list) = - let length = List.length str in - let buffer = Buffer.create length in - let append charcode = - let addition = escape_wchar charcode in - Buffer.add_string buffer addition - in - List.iter append str; - Buffer.contents buffer diff --git a/cil/src/escape.mli b/cil/src/escape.mli deleted file mode 100644 index b932ef1..0000000 --- a/cil/src/escape.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* - * - * Copyright (c) 2003, - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* - * Character and string escaping utilities - *) - -(** OCaml types used to represent wide characters and strings *) -type wchar = int64 -type wstring = wchar list - -(** escape various constructs in accordance with C lexical rules *) -val escape_char : char -> string -val escape_string : string -> string -val escape_wchar : wchar -> string -val escape_wstring : wstring -> string diff --git a/cil/src/ext/astslicer.ml b/cil/src/ext/astslicer.ml deleted file mode 100644 index ffba482..0000000 --- a/cil/src/ext/astslicer.ml +++ /dev/null @@ -1,454 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -open Cil -module E = Errormsg -(* - * Weimer: an AST Slicer for use in Daniel's Delta Debugging Algorithm. - *) -let debug = ref false - -(* - * This type encapsulates a mapping form program locations to names - * in our naming convention. - *) -type enumeration_info = { - statements : (stmt, string) Hashtbl.t ; - instructions : (instr, string) Hashtbl.t ; -} - -(********************************************************************** - * Enumerate 1 - * - * Given a cil file, enumerate all of the statement names in it using - * our naming scheme. - **********************************************************************) -let enumerate out (f : Cil.file) = - let st_ht = Hashtbl.create 32767 in - let in_ht = Hashtbl.create 32767 in - - let emit base i ht elt = - let str = Printf.sprintf "%s.%d" base !i in - Printf.fprintf out "%s\n" str ; - Hashtbl.add ht elt str ; - incr i - in - let emit_call base i str2 ht elt = - let str = Printf.sprintf "%s.%d" base !i in - Printf.fprintf out "%s - %s\n" str str2 ; - Hashtbl.add ht elt str ; - incr i - in - let descend base i = - let res = (Printf.sprintf "%s.%d" base !i),(ref 0) in - res - in - let rec doBlock b base i = - doStmtList b.bstmts base i - and doStmtList sl base i = - List.iter (fun s -> match s.skind with - | Instr(il) -> doIL il base i - | Return(_,_) - | Goto(_,_) - | Continue(_) - | Break(_) -> emit base i st_ht s - | If(e,b1,b2,_) -> - emit base i st_ht s ; - decr i ; - Printf.fprintf out "(\n" ; - let base',i' = descend base i in - doBlock b1 base' i' ; - Printf.fprintf out ") (\n" ; - let base'',i'' = descend base i in - doBlock b2 base'' i'' ; - Printf.fprintf out ")\n" ; - incr i - | Switch(_,b,_,_) -(* - | Loop(b,_,_,_) -*) - | While(_,b,_) - | DoWhile(_,b,_) - | For(_,_,_,b,_) - | Block(b) -> - emit base i st_ht s ; - decr i ; - let base',i' = descend base i in - Printf.fprintf out "(\n" ; - doBlock b base' i' ; - Printf.fprintf out ")\n" ; - incr i - | TryExcept _ | TryFinally _ -> - E.s (E.unimp "astslicer:enumerate") - ) sl - and doIL il base i = - List.iter (fun ins -> match ins with - | Set _ - | Asm _ -> emit base i in_ht ins - | Call(_,(Lval(Var(vi),NoOffset)),_,_) -> - emit_call base i vi.vname in_ht ins - | Call(_,f,_,_) -> emit_call base i "*" in_ht ins - ) il - in - let doGlobal g = match g with - | GFun(fd,_) -> - Printf.fprintf out "%s (\n" fd.svar.vname ; - let cur = ref 0 in - doBlock fd.sbody fd.svar.vname cur ; - Printf.fprintf out ")\n" ; - () - | _ -> () - in - List.iter doGlobal f.globals ; - { statements = st_ht ; - instructions = in_ht ; } - -(********************************************************************** - * Enumerate 2 - * - * Given a cil file and some enumeration information, do a log-calls-like - * transformation on it that prints out our names as you reach them. - **********************************************************************) -(* - * This is the visitor that handles annotations - *) -let print_it pfun name = - ((Call(None,Lval(Var(pfun),NoOffset), - [mkString (name ^ "\n")],locUnknown))) - -class enumVisitor pfun st_ht in_ht = object - inherit nopCilVisitor - method vinst i = - if Hashtbl.mem in_ht i then begin - let name = Hashtbl.find in_ht i in - let newinst = print_it pfun name in - ChangeTo([newinst ; i]) - end else - DoChildren - method vstmt s = - if Hashtbl.mem st_ht s then begin - let name = Hashtbl.find st_ht s in - let newinst = print_it pfun name in - let newstmt = mkStmtOneInstr newinst in - let newblock = mkBlock [newstmt ; s] in - let replace_with = mkStmt (Block(newblock)) in - ChangeDoChildrenPost(s,(fun i -> replace_with)) - end else - DoChildren - method vfunc f = - let newinst = print_it pfun f.svar.vname in - let newstmt = mkStmtOneInstr newinst in - let new_f = { f with sbody = { f.sbody with - bstmts = newstmt :: f.sbody.bstmts }} in - ChangeDoChildrenPost(new_f,(fun i -> i)) -end - -let annotate (f : Cil.file) ei = begin - (* Create a prototype for the logging function *) - let printfFun = - let fdec = emptyFunction "printf" in - let argf = makeLocalVar fdec "format" charConstPtrType in - fdec.svar.vtype <- TFun(intType, Some [ ("format", charConstPtrType, [])], - true, []); - fdec - in - let visitor = (new enumVisitor printfFun.svar ei.statements - ei.instructions) in - visitCilFileSameGlobals visitor f; - f -end - -(********************************************************************** - * STAGE 2 - * - * Perform a transitive-closure-like operation on the parts of the program - * that the user wants to keep. We use a CIL visitor to walk around - * and a number of hash tables to keep track of the things we want to keep. - **********************************************************************) -(* - * Hashtables: - * ws - wanted stmts - * wi - wanted instructions - * wt - wanted typeinfo - * wc - wanted compinfo - * we - wanted enuminfo - * wv - wanted varinfo - *) - -let mode = ref false (* was our parented wanted? *) -let finished = ref true (* set to false if we update something *) - -(* In the given hashtable, mark the given element was "wanted" *) -let update ht elt = - if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then () - else begin - Hashtbl.add ht elt true ; - finished := false - end - -(* Handle a particular stage of the AST tree walk. Use "mode" (i.e., - * whether our parent was wanted) and the hashtable (which tells us whether - * the user had any special instructions for this element) to determine - * what do to. *) -let handle ht elt rep = - if !mode then begin - if Hashtbl.mem ht elt && (Hashtbl.find ht elt = false) then begin - (* our parent is Wanted but we were told to ignore this subtree, - * so we won't be wanted. *) - mode := false ; - ChangeDoChildrenPost(rep,(fun elt -> mode := true ; elt)) - end else begin - (* we were not told to ignore this subtree, and our parent is - * Wanted, so we will be Wanted too! *) - update ht elt ; - DoChildren - end - end else if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then begin - (* our parent was not wanted but we were wanted, so turn the - * mode on for now *) - mode := true ; - ChangeDoChildrenPost(rep,(fun elt -> mode := false ; elt)) - end else - DoChildren - -let handle_no_default ht elt rep old_mode = - if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then begin - (* our parent was not wanted but we were wanted, so turn the - * mode on for now *) - mode := true ; - ChangeDoChildrenPost(rep,(fun elt -> mode := old_mode ; elt)) - end else begin - mode := false ; - ChangeDoChildrenPost(rep,(fun elt -> mode := old_mode ; elt)) - end - -(* - * This is the visitor that handles elements (marks them as wanted) - *) -class transVisitor ws wi wt wc we wv = object - inherit nopCilVisitor - - method vvdec vi = handle_no_default wv vi vi !mode - method vvrbl vi = handle wv vi vi - method vinst i = handle wi i [i] - method vstmt s = handle ws s s - method vfunc f = handle wv f.svar f - method vglob g = begin - match g with - | GType(ti,_) -> handle wt ti [g] - | GCompTag(ci,_) - | GCompTagDecl(ci,_) -> handle wc ci [g] - | GEnumTag(ei,_) - | GEnumTagDecl(ei,_) -> handle we ei [g] - | GVarDecl(vi,_) - | GVar(vi,_,_) -> handle wv vi [g] - | GFun(f,_) -> handle wv f.svar [g] - | _ -> DoChildren - end - method vtype t = begin - match t with - | TNamed(ti,_) -> handle wt ti t - | TComp(ci,_) -> handle wc ci t - | TEnum(ei,_) -> handle we ei t - | _ -> DoChildren - end -end - -(********************************************************************** - * STAGE 3 - * - * Eliminate all of the elements from the program that are not marked - * "keep". - **********************************************************************) -(* - * This is the visitor that throws away elements - *) -let handle ht elt keep drop = - if (Hashtbl.mem ht elt) && (Hashtbl.find ht elt = true) then - (* DoChildren *) ChangeDoChildrenPost(keep,(fun a -> a)) - else - ChangeTo(drop) - -class dropVisitor ws wi wt wc we wv = object - inherit nopCilVisitor - - method vinst i = handle wi i [i] [] - method vstmt s = handle ws s s (mkStmt (Instr([]))) - method vglob g = begin - match g with - | GType(ti,_) -> handle wt ti [g] [] - | GCompTag(ci,_) - | GCompTagDecl(ci,_) -> handle wc ci [g] [] - | GEnumTag(ei,_) - | GEnumTagDecl(ei,_) -> handle we ei [g] [] - | GVarDecl(vi,_) - | GVar(vi,_,_) -> handle wv vi [g] [] - | GFun(f,l) -> - let new_locals = List.filter (fun vi -> - Hashtbl.mem wv vi && (Hashtbl.find wv vi = true)) f.slocals in - let new_fundec = { f with slocals = new_locals} in - handle wv f.svar [(GFun(new_fundec,l))] [] - | _ -> DoChildren - end -end - -(********************************************************************** - * STAGE 1 - * - * Mark up the file with user-given information about what to keep and - * what to drop. - **********************************************************************) -type mark = Wanted | Unwanted | Unspecified -(* Given a cil file and a list of strings, mark all of the given ASTSlicer - * points as wanted or unwanted. *) -let mark_file (f : Cil.file) (names : (string, mark) Hashtbl.t) = - let ws = Hashtbl.create 32767 in - let wi = Hashtbl.create 32767 in - let wt = Hashtbl.create 32767 in - let wc = Hashtbl.create 32767 in - let we = Hashtbl.create 32767 in - let wv = Hashtbl.create 32767 in - if !debug then Printf.printf "Applying user marks to file ...\n" ; - let descend base i = - let res = (Printf.sprintf "%s.%d" base !i),(ref 0) in - res - in - let check base i (default : mark) = - let str = Printf.sprintf "%s.%d" base !i in - if !debug then Printf.printf "Looking for [%s]\n" str ; - try Hashtbl.find names str - with _ -> default - in - let mark ht stmt wanted = match wanted with - Unwanted -> Hashtbl.replace ht stmt false - | Wanted -> Hashtbl.replace ht stmt true - | Unspecified -> () - in - let rec doBlock b base i default = - doStmtList b.bstmts base i default - and doStmtList sl base i default = - List.iter (fun s -> match s.skind with - | Instr(il) -> doIL il base i default - | Return(_,_) - | Goto(_,_) - | Continue(_) - | Break(_) -> - mark ws s (check base i default) ; incr i - | If(e,b1,b2,_) -> - let inside = check base i default in - mark ws s inside ; - let base',i' = descend base i in - doBlock b1 base' i' inside ; - let base'',i'' = descend base i in - doBlock b2 base'' i'' inside ; - incr i - | Switch(_,b,_,_) -(* - | Loop(b,_,_,_) -*) - | While(_,b,_) - | DoWhile(_,b,_) - | For(_,_,_,b,_) - | Block(b) -> - let inside = check base i default in - mark ws s inside ; - let base',i' = descend base i in - doBlock b base' i' inside ; - incr i - | TryExcept _ | TryFinally _ -> - E.s (E.unimp "astslicer: mark") - ) sl - and doIL il base i default = - List.iter (fun ins -> mark wi ins (check base i default) ; incr i) il - in - let doGlobal g = match g with - | GFun(fd,_) -> - let cur = ref 0 in - if Hashtbl.mem names fd.svar.vname then begin - if Hashtbl.find names fd.svar.vname = Wanted then begin - Hashtbl.replace wv fd.svar true ; - doBlock fd.sbody fd.svar.vname cur (Wanted); - end else begin - Hashtbl.replace wv fd.svar false ; - doBlock fd.sbody fd.svar.vname cur (Unspecified); - end - end else begin - doBlock fd.sbody fd.svar.vname cur (Unspecified); - end - | _ -> () - in - List.iter doGlobal f.globals ; - if !debug then begin - Hashtbl.iter (fun k v -> - ignore (Pretty.printf "want-s %b %a\n" v d_stmt k)) ws ; - Hashtbl.iter (fun k v -> - ignore (Pretty.printf "want-i %b %a\n" v d_instr k)) wi ; - Hashtbl.iter (fun k v -> - ignore (Pretty.printf "want-v %b %s\n" v k.vname)) wv ; - end ; - (* - * Now repeatedly mark all other things that must be kept. - *) - let visitor = (new transVisitor ws wi wt wc we wv) in - finished := false ; - if !debug then (Printf.printf "\nPerforming Transitive Closure\n\n" ); - while not !finished do - finished := true ; - visitCilFileSameGlobals visitor f - done ; - if !debug then begin - Hashtbl.iter (fun k v -> - if v then ignore (Pretty.printf "want-s %a\n" d_stmt k)) ws ; - Hashtbl.iter (fun k v -> - if v then ignore (Pretty.printf "want-i %a\n" d_instr k)) wi ; - Hashtbl.iter (fun k v -> - if v then ignore (Pretty.printf "want-t %s\n" k.tname)) wt ; - Hashtbl.iter (fun k v -> - if v then ignore (Pretty.printf "want-c %s\n" k.cname)) wc ; - Hashtbl.iter (fun k v -> - if v then ignore (Pretty.printf "want-e %s\n" k.ename)) we ; - Hashtbl.iter (fun k v -> - if v then ignore (Pretty.printf "want-v %s\n" k.vname)) wv ; - end ; - - (* - * Now drop everything we didn't need. - *) - if !debug then (Printf.printf "Dropping Unwanted Elements\n" ); - let visitor = (new dropVisitor ws wi wt wc we wv) in - visitCilFile visitor f diff --git a/cil/src/ext/availexps.ml b/cil/src/ext/availexps.ml deleted file mode 100644 index 28c22c0..0000000 --- a/cil/src/ext/availexps.ml +++ /dev/null @@ -1,359 +0,0 @@ -(* compute available expressions, although in a somewhat - non-traditional way. the abstract state is a mapping from - variable ids to expressions as opposed to a set of - expressions *) - -open Cil -open Pretty - -module E = Errormsg -module DF = Dataflow -module UD = Usedef -module IH = Inthash -module U = Util -module S = Stats - -let debug = ref false - -(* exp IH.t -> exp IH.t -> bool *) -let eh_equals eh1 eh2 = - if not(IH.length eh1 = IH.length eh2) - then false - else IH.fold (fun vid e b -> - if not b then b else - try let e2 = IH.find eh2 vid in - if not(Util.equals e e2) - then false - else true - with Not_found -> false) - eh1 true - -let eh_pretty () eh = line ++ seq line (fun (vid,e) -> - text "AE:vid:" ++ num vid ++ text ": " ++ - (d_exp () e)) (IH.tolist eh) - -(* the result must be the intersection of eh1 and eh2 *) -(* exp IH.t -> exp IH.t -> exp IH.t *) -let eh_combine eh1 eh2 = - if !debug then ignore(E.log "eh_combine: combining %a\n and\n %a\n" - eh_pretty eh1 eh_pretty eh2); - let eh' = IH.copy eh1 in (* eh' gets all of eh1 *) - IH.iter (fun vid e1 -> - try let e2l = IH.find_all eh2 vid in - if not(List.exists (fun e2 -> Util.equals e1 e2) e2l) - (* remove things from eh' that eh2 doesn't have *) - then let e1l = IH.find_all eh' vid in - let e1l' = List.filter (fun e -> not(Util.equals e e1)) e1l in - IH.remove_all eh' vid; - List.iter (fun e -> IH.add eh' vid e) e1l' - with Not_found -> - IH.remove_all eh' vid) eh1; - if !debug then ignore(E.log "with result %a\n" - eh_pretty eh'); - eh' - -(* On a memory write, kill expressions containing memory writes - * or variables whose address has been taken. *) -let exp_ok = ref false -class memReadOrAddrOfFinderClass = object(self) - inherit nopCilVisitor - - method vexpr e = match e with - Lval(Mem _, _) -> - exp_ok := true; - SkipChildren - | _ -> DoChildren - - method vvrbl vi = - if vi.vaddrof then - (exp_ok := true; - SkipChildren) - else DoChildren - -end - -let memReadOrAddrOfFinder = new memReadOrAddrOfFinderClass - -(* exp -> bool *) -let exp_has_mem_read e = - exp_ok := false; - ignore(visitCilExpr memReadOrAddrOfFinder e); - !exp_ok - -let eh_kill_mem eh = - IH.iter (fun vid e -> - if exp_has_mem_read e - then IH.remove eh vid) - eh - -(* need to kill exps containing a particular vi sometimes *) -let has_vi = ref false -class viFinderClass vi = object(self) - inherit nopCilVisitor - - method vvrbl vi' = - if vi.vid = vi'.vid - then (has_vi := true; SkipChildren) - else DoChildren - -end - -let exp_has_vi e vi = - let vis = new viFinderClass vi in - has_vi := false; - ignore(visitCilExpr vis e); - !has_vi - -let eh_kill_vi eh vi = - IH.iter (fun vid e -> - if exp_has_vi e vi - then IH.remove eh vid) - eh - -let varHash = IH.create 32 - -let eh_kill_addrof_or_global eh = - if !debug then ignore(E.log "eh_kill: in eh_kill\n"); - IH.iter (fun vid e -> - try let vi = IH.find varHash vid in - if vi.vaddrof - then begin - if !debug then ignore(E.log "eh_kill: %s has its address taken\n" - vi.vname); - IH.remove eh vid - end - else if vi.vglob - then begin - if !debug then ignore(E.log "eh_kill: %s is global\n" - vi.vname); - IH.remove eh vid - end - with Not_found -> ()) eh - -let eh_handle_inst i eh = match i with - (* if a pointer write, kill things with read in them. - also kill mappings from vars that have had their address taken, - and globals. - otherwise kill things with lv in them and add e *) - Set(lv,e,_) -> (match lv with - (Mem _, _) -> - (eh_kill_mem eh; - eh_kill_addrof_or_global eh; - eh) - | (Var vi, NoOffset) -> - (match e with - Lval(Var vi', NoOffset) -> (* ignore x = x *) - if vi'.vid = vi.vid then eh else - (IH.replace eh vi.vid e; - eh_kill_vi eh vi; - eh) - | _ -> - (IH.replace eh vi.vid e; - eh_kill_vi eh vi; - eh)) - | _ -> eh) (* do nothing for now. *) -| Call(Some(Var vi,NoOffset),_,_,_) -> - (IH.remove eh vi.vid; - eh_kill_vi eh vi; - eh_kill_mem eh; - eh_kill_addrof_or_global eh; - eh) -| Call(_,_,_,_) -> - (eh_kill_mem eh; - eh_kill_addrof_or_global eh; - eh) -| Asm(_,_,_,_,_,_) -> - let _,d = UD.computeUseDefInstr i in - (UD.VS.iter (fun vi -> - eh_kill_vi eh vi) d; - eh) - -let allExpHash = IH.create 128 - -module AvailableExps = - struct - - let name = "Available Expressions" - - let debug = debug - - (* mapping from var id to expression *) - type t = exp IH.t - - let copy = IH.copy - - let stmtStartData = IH.create 64 - - let pretty = eh_pretty - - let computeFirstPredecessor stm eh = - eh_combine (IH.copy allExpHash) eh - - let combinePredecessors (stm:stmt) ~(old:t) (eh:t) = - if S.time "eh_equals" (eh_equals old) eh then None else - Some(S.time "eh_combine" (eh_combine old) eh) - - let doInstr i eh = - let action = eh_handle_inst i in - DF.Post(action) - - let doStmt stm astate = DF.SDefault - - let doGuard c astate = DF.GDefault - - let filterStmt stm = true - - end - -module AE = DF.ForwardsDataFlow(AvailableExps) - -(* make an exp IH.t with everything in it, - * also, fill in varHash while we're here. - *) -class expCollectorClass = object(self) - inherit nopCilVisitor - - method vinst i = match i with - Set((Var vi,NoOffset),e,_) -> - let e2l = IH.find_all allExpHash vi.vid in - if not(List.exists (fun e2 -> Util.equals e e2) e2l) - then IH.add allExpHash vi.vid e; - DoChildren - | _ -> DoChildren - - method vvrbl vi = - (if not(IH.mem varHash vi.vid) - then - (if !debug && vi.vglob then ignore(E.log "%s is global\n" vi.vname); - if !debug && not(vi.vglob) then ignore(E.log "%s is not global\n" vi.vname); - IH.add varHash vi.vid vi)); - DoChildren - -end - -let expCollector = new expCollectorClass - -let make_all_exps fd = - IH.clear allExpHash; - IH.clear varHash; - ignore(visitCilFunction expCollector fd) - - - -(* set all statement data to allExpHash, make - * a list of statements - *) -let all_stmts = ref [] -class allExpSetterClass = object(self) - inherit nopCilVisitor - - method vstmt s = - all_stmts := s :: (!all_stmts); - IH.add AvailableExps.stmtStartData s.sid (IH.copy allExpHash); - DoChildren - -end - -let allExpSetter = new allExpSetterClass - -let set_all_exps fd = - IH.clear AvailableExps.stmtStartData; - ignore(visitCilFunction allExpSetter fd) - -(* - * Computes AEs for function fd. - * - * - *) -(*let iAEsHtbl = Hashtbl.create 128*) -let computeAEs fd = - try let slst = fd.sbody.bstmts in - let first_stm = List.hd slst in - S.time "make_all_exps" make_all_exps fd; - all_stmts := []; - (*S.time "set_all_exps" set_all_exps fd;*) - (*Hashtbl.clear iAEsHtbl;*) - (*IH.clear (IH.find AvailableExps.stmtStartData first_stm.sid);*) - IH.add AvailableExps.stmtStartData first_stm.sid (IH.create 4); - S.time "compute" AE.compute [first_stm](*(List.rev !all_stmts)*) - with Failure "hd" -> if !debug then ignore(E.log "fn w/ no stmts?\n") - | Not_found -> if !debug then ignore(E.log "no data for first_stm?\n") - - -(* get the AE data for a statement *) -let getAEs sid = - try Some(IH.find AvailableExps.stmtStartData sid) - with Not_found -> None - -(* get the AE data for an instruction list *) -let instrAEs il sid eh out = - (*if Hashtbl.mem iAEsHtbl (sid,out) - then Hashtbl.find iAEsHtbl (sid,out) - else*) - let proc_one hil i = - match hil with - [] -> let eh' = IH.copy eh in - let eh'' = eh_handle_inst i eh' in - (*if !debug then ignore(E.log "instrAEs: proc_one []: for %a\n data is %a\n" - d_instr i eh_pretty eh'');*) - eh''::hil - | eh'::ehrst as l -> - let eh' = IH.copy eh' in - let eh'' = eh_handle_inst i eh' in - (*if !debug then ignore(E.log "instrAEs: proc_one: for %a\n data is %a\n" - d_instr i eh_pretty eh'');*) - eh''::l - in - let folded = List.fold_left proc_one [eh] il in - (*let foldedout = List.tl (List.rev folded) in*) - let foldednotout = List.rev (List.tl folded) in - (*Hashtbl.add iAEsHtbl (sid,true) foldedout; - Hashtbl.add iAEsHtbl (sid,false) foldednotout;*) - (*if out then foldedout else*) foldednotout - -class aeVisitorClass = object(self) - inherit nopCilVisitor - - val mutable sid = -1 - - val mutable ae_dat_lst = [] - - val mutable cur_ae_dat = None - - method vstmt stm = - sid <- stm.sid; - match getAEs sid with - None -> - if !debug then ignore(E.log "aeVis: stm %d has no data\n" sid); - cur_ae_dat <- None; - DoChildren - | Some eh -> - match stm.skind with - Instr il -> - if !debug then ignore(E.log "aeVist: visit il\n"); - ae_dat_lst <- S.time "instrAEs" (instrAEs il stm.sid eh) false; - DoChildren - | _ -> - if !debug then ignore(E.log "aeVisit: visit non-il\n"); - cur_ae_dat <- None; - DoChildren - - method vinst i = - if !debug then ignore(E.log "aeVist: before %a, ae_dat_lst is %d long\n" - d_instr i (List.length ae_dat_lst)); - try - let data = List.hd ae_dat_lst in - cur_ae_dat <- Some(data); - ae_dat_lst <- List.tl ae_dat_lst; - if !debug then ignore(E.log "aeVisit: data is %a\n" eh_pretty data); - DoChildren - with Failure "hd" -> - if !debug then ignore(E.log "aeVis: il ae_dat_lst mismatch\n"); - DoChildren - - method get_cur_eh () = - match cur_ae_dat with - None -> getAEs sid - | Some eh -> Some eh - -end diff --git a/cil/src/ext/bitmap.ml b/cil/src/ext/bitmap.ml deleted file mode 100644 index da1f8b9..0000000 --- a/cil/src/ext/bitmap.ml +++ /dev/null @@ -1,224 +0,0 @@ - - (* Imperative bitmaps *) -type t = { mutable nrWords : int; - mutable nrBits : int; (* This is 31 * nrWords *) - mutable bitmap : int array } - - - (* Enlarge a bitmap to contain at - * least newBits *) -let enlarge b newWords = - let newbitmap = - if newWords > b.nrWords then - let a = Array.create newWords 0 in - Array.blit b.bitmap 0 a 0 b.nrWords; - a - else - b.bitmap in - b.nrWords <- newWords; - b.nrBits <- (newWords lsl 5) - newWords; - b.bitmap <- newbitmap - - - (* Create a new empty bitmap *) -let make size = - let wrd = (size + 30) / 31 in - { nrWords = wrd; - nrBits = (wrd lsl 5) - wrd; - bitmap = Array.make wrd 0 - } - -let size t = t.nrBits - (* Make an initialized array *) -let init size how = - let wrd = (size + 30) / 31 in - let how' w = - let first = (w lsl 5) - w in - let last = min size (first + 31) in - let rec loop i acc = - if i >= last then acc - else - let acc' = acc lsl 1 in - if how i then loop (i + 1) (acc' lor 1) - else loop (i + 1) acc' - in - loop first 0 - in - { nrWords = wrd; - nrBits = (wrd lsl 5) - wrd; - bitmap = Array.init wrd how' - } - -let clone b = - { nrWords = b.nrWords; - nrBits = b.nrBits; - bitmap = Array.copy b.bitmap; - } - -let cloneEmpty b = - { nrWords = b.nrWords; - nrBits = b.nrBits; - bitmap = Array.make b.nrWords 0; - } - -let union b1 b2 = - begin - let n = b2.nrWords in - if b1.nrWords < n then enlarge b1 n else (); - let a1 = b1.bitmap in - let a2 = b2.bitmap in - let changed = ref false in - for i=0 to n - 1 do - begin - let t = a1.(i) in - let upd = t lor a2.(i) in - let _ = if upd <> t then changed := true else () in - Array.unsafe_set a1 i upd - end - done; - ! changed - end - (* lin += (lout - def) *) -let accLive lin lout def = - begin (* Need to enlarge def to lout *) - let n = lout.nrWords in - if def.nrWords < n then enlarge def n else (); - (* Need to enlarge lin to lout *) - if lin.nrWords < n then enlarge lin n else (); - let changed = ref false in - let alin = lin.bitmap in - let alout = lout.bitmap in - let adef = def.bitmap in - for i=0 to n - 1 do - begin - let old = alin.(i) in - let nw = old lor (alout.(i) land (lnot adef.(i))) in - alin.(i) <- nw; - changed := (old <> nw) || (!changed) - end - done; - !changed - end - - (* b1 *= b2 *) -let inters b1 b2 = - begin - let n = min b1.nrWords b2.nrWords in - let a1 = b1.bitmap in - let a2 = b2.bitmap in - for i=0 to n - 1 do - begin - a1.(i) <- a1.(i) land a2.(i) - end - done; - if n < b1.nrWords then - Array.fill a1 n (b1.nrWords - n) 0 - else - () - end - -let emptyInt b start = - let n = b.nrWords in - let a = b.bitmap in - let rec loop i = i >= n || (a.(i) = 0 && loop (i + 1)) - in - loop start - -let empty b = emptyInt b 0 - - (* b1 =? b2 *) -let equal b1 b2 = - begin - let n = min b1.nrWords b2.nrWords in - let a1 = b1.bitmap in - let a2 = b2.bitmap in - let res = ref true in - for i=0 to n - 1 do - begin - if a1.(i) != a2.(i) then res := false else () - end - done; - if !res then - if b1.nrWords > n then - emptyInt b1 n - else if b2.nrWords > n then - emptyInt b2 n - else - true - else - false - end - -let assign b1 b2 = - begin - let n = b2.nrWords in - if b1.nrWords < n then enlarge b1 n else (); - let a1 = b1.bitmap in - let a2 = b2.bitmap in - Array.blit a2 0 a1 0 n - end - - (* b1 -= b2 *) -let diff b1 b2 = - begin - let n = min b1.nrWords b2.nrWords in - let a1 = b1.bitmap in - let a2 = b2.bitmap in - for i=0 to n - 1 do - a1.(i) <- a1.(i) land (lnot a2.(i)) - done; - if n < b1.nrWords then - Array.fill a1 n (b1.nrWords - n) 0 - else - () - end - - - - -let get bmp i = - assert (i >= 0); - if i >= bmp.nrBits then enlarge bmp (i / 31 + 1) else (); - let wrd = i / 31 in - let msk = 1 lsl (i + wrd - (wrd lsl 5)) in - bmp.bitmap.(wrd) land msk != 0 - - -let set bmp i tv = - assert(i >= 0); - let wrd = i / 31 in - let msk = 1 lsl (i + wrd - (wrd lsl 5)) in - if i >= bmp.nrBits then enlarge bmp (wrd + 1) else (); - if tv then - bmp.bitmap.(wrd) <- bmp.bitmap.(wrd) lor msk - else - bmp.bitmap.(wrd) <- bmp.bitmap.(wrd) land (lnot msk) - - - - (* Iterate over all elements in a - * bitmap *) -let fold f bmp arg = - let a = bmp.bitmap in - let n = bmp.nrWords in - let rec allWords i bit arg = - if i >= n then - arg - else - let rec allBits msk bit left arg = - if left = 0 then - allWords (i + 1) bit arg - else - allBits ((lsr) msk 1) (bit + 1) (left - 1) - (if (land) msk 1 != 0 then f arg bit else arg) - in - allBits a.(i) bit 31 arg - in - allWords 0 0 arg - - -let iter f t = fold (fun x y -> f y) t () - -let toList bmp = fold (fun acc i -> i :: acc) bmp [] - -let card bmp = fold (fun acc _ -> acc + 1) bmp 0 diff --git a/cil/src/ext/bitmap.mli b/cil/src/ext/bitmap.mli deleted file mode 100644 index 5247e35..0000000 --- a/cil/src/ext/bitmap.mli +++ /dev/null @@ -1,50 +0,0 @@ - - (* Imperative bitmaps *) - -type t - (* Create a bitmap given the number - * of bits *) -val make : int -> t -val init : int -> (int -> bool) -> t (* Also initialize it *) - -val size : t -> int (* How much space it is reserved *) - - (* The cardinality of a set *) -val card : t -> int - - (* Make a copy of a bitmap *) -val clone : t -> t - -val cloneEmpty : t -> t (* An empty set with the same - * dimentions *) - -val set : t -> int -> bool -> unit -val get : t -> int -> bool - (* destructive union. The first - * element is updated. Returns true - * if any change was actually - * necessary *) -val union : t -> t -> bool - - (* accLive livein liveout def. Does - * liveIn += (liveout - def) *) -val accLive : t -> t -> t -> bool - - (* Copy the second argument onto the - * first *) -val assign : t -> t -> unit - - -val inters : t -> t -> unit -val diff : t -> t -> unit - - -val empty : t -> bool - -val equal : t -> t -> bool - -val toList : t -> int list - -val iter : (int -> unit) -> t -> unit -val fold : ('a -> int -> 'a) -> t -> 'a -> 'a - diff --git a/cil/src/ext/blockinggraph.ml b/cil/src/ext/blockinggraph.ml deleted file mode 100644 index 281678a..0000000 --- a/cil/src/ext/blockinggraph.ml +++ /dev/null @@ -1,769 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -open Cil -open Pretty -module E = Errormsg - -let debug = false - -let fingerprintAll = true - - -type blockkind = - NoBlock - | BlockTrans - | BlockPoint - | EndPoint - -(* For each function we have a node *) -type node = -{ - nodeid: int; - name: string; - mutable scanned: bool; - mutable expand: bool; - mutable fptr: bool; - mutable stacksize: int; - mutable fds: fundec option; - mutable bkind: blockkind; - mutable origkind: blockkind; - mutable preds: node list; - mutable succs: node list; - mutable predstmts: (stmt * node) list; -} - -type blockpt = -{ - id: int; - point: stmt; - callfun: string; - infun: string; - mutable leadsto: blockpt list; -} - - -(* Fresh ids for each node. *) -let curNodeNum : int ref = ref 0 -let getFreshNodeNum () : int = - let num = !curNodeNum in - incr curNodeNum; - num - -(* Initialize a node. *) -let newNode (name: string) (fptr: bool) (mangle: bool) : node = - let id = getFreshNodeNum () in - { nodeid = id; name = if mangle then name ^ (string_of_int id) else name; - scanned = false; expand = false; - fptr = fptr; stacksize = 0; fds = None; - bkind = NoBlock; origkind = NoBlock; - preds = []; succs = []; predstmts = []; } - - -(* My type signature ignores attributes and function pointers. *) -let myTypeSig (t: typ) : typsig = - let rec removeFunPtrs (ts: typsig) : typsig = - match ts with - TSPtr (TSFun _, a) -> - TSPtr (TSBase voidType, a) - | TSPtr (base, a) -> - TSPtr (removeFunPtrs base, a) - | TSArray (base, e, a) -> - TSArray (removeFunPtrs base, e, a) - | TSFun (ret, args, v, a) -> - TSFun (removeFunPtrs ret, List.map removeFunPtrs args, v, a) - | _ -> ts - in - removeFunPtrs (typeSigWithAttrs (fun _ -> []) t) - - -(* We add a dummy function whose name is "@@functionPointer@@" that is called - * at all invocations of function pointers and itself calls all functions - * whose address is taken. *) -let functionPointerName = "@@functionPointer@@" - -(* We map names to nodes *) -let functionNodes: (string, node) Hashtbl.t = Hashtbl.create 113 -let getFunctionNode (n: string) : node = - Util.memoize - functionNodes - n - (fun _ -> newNode n false false) - -(* We map types to nodes for function pointers *) -let functionPtrNodes: (typsig, node) Hashtbl.t = Hashtbl.create 113 -let getFunctionPtrNode (t: typ) : node = - Util.memoize - functionPtrNodes - (myTypeSig t) - (fun _ -> newNode functionPointerName true true) - -let startNode: node = newNode "@@startNode@@" true false - - -(* -(** Dump the function call graph. *) -let dumpFunctionCallGraph (start: node) = - Hashtbl.iter (fun _ x -> x.scanned <- false) functionNodes; - let rec dumpOneNode (ind: int) (n: node) : unit = - output_string !E.logChannel "\n"; - for i = 0 to ind do - output_string !E.logChannel " " - done; - output_string !E.logChannel (n.name ^ " "); - begin - match n.bkind with - NoBlock -> () - | BlockTrans -> output_string !E.logChannel " " - | BlockPoint -> output_string !E.logChannel " " - | EndPoint -> output_string !E.logChannel " " - end; - if n.scanned then (* Already dumped *) - output_string !E.logChannel " " - else begin - n.scanned <- true; - List.iter (fun n -> if n.bkind <> EndPoint then dumpOneNode (ind + 1) n) - n.succs - end - in - dumpOneNode 0 start; - output_string !E.logChannel "\n\n" -*) - -let dumpFunctionCallGraphToFile () = - let channel = open_out "graph" in - let dumpNode _ (n: node) : unit = - let first = ref true in - let dumpSucc (n: node) : unit = - if !first then - first := false - else - output_string channel ","; - output_string channel n.name - in - output_string channel (string_of_int n.nodeid); - output_string channel ":"; - output_string channel (string_of_int n.stacksize); - output_string channel ":"; - if n.fds = None && not n.fptr then - output_string channel "x"; - output_string channel ":"; - output_string channel n.name; - output_string channel ":"; - List.iter dumpSucc n.succs; - output_string channel "\n"; - in - dumpNode () startNode; - Hashtbl.iter dumpNode functionNodes; - Hashtbl.iter dumpNode functionPtrNodes; - close_out channel - - -let addCall (callerNode: node) (calleeNode: node) (sopt: stmt option) = - if not (List.exists (fun n -> n.name = calleeNode.name) - callerNode.succs) then begin - if debug then - ignore (E.log "found call from %s to %s\n" - callerNode.name calleeNode.name); - callerNode.succs <- calleeNode :: callerNode.succs; - calleeNode.preds <- callerNode :: calleeNode.preds; - end; - match sopt with - Some s -> - if not (List.exists (fun (s', _) -> s' = s) calleeNode.predstmts) then - calleeNode.predstmts <- (s, callerNode) :: calleeNode.predstmts - | None -> () - - -class findCallsVisitor (host: node) : cilVisitor = object - inherit nopCilVisitor - - val mutable curStmt : stmt ref = ref (mkEmptyStmt ()) - - method vstmt s = - curStmt := s; - DoChildren - - method vinst i = - match i with - | Call(_,Lval(Var(vi),NoOffset),args,l) -> - addCall host (getFunctionNode vi.vname) (Some !curStmt); - SkipChildren - - | Call(_,e,_,l) -> (* Calling a function pointer *) - addCall host (getFunctionPtrNode (typeOf e)) (Some !curStmt); - SkipChildren - - | _ -> SkipChildren (* No calls in other instructions *) - - (* There are no calls in expressions and types *) - method vexpr e = SkipChildren - method vtype t = SkipChildren - -end - - -let endPt = { id = 0; point = mkEmptyStmt (); callfun = "end"; infun = "end"; - leadsto = []; } - -(* These values will be initialized for real in makeBlockingGraph. *) -let curId : int ref = ref 1 -let startName : string ref = ref "" -let blockingPoints : blockpt list ref = ref [] -let blockingPointsNew : blockpt Queue.t = Queue.create () -let blockingPointsHash : (int, blockpt) Hashtbl.t = Hashtbl.create 113 - -let getFreshNum () : int = - let num = !curId in - curId := !curId + 1; - num - -let getBlockPt (s: stmt) (cfun: string) (ifun: string) : blockpt = - try - Hashtbl.find blockingPointsHash s.sid - with Not_found -> - let num = getFreshNum () in - let bpt = { id = num; point = s; callfun = cfun; infun = ifun; - leadsto = []; } in - Hashtbl.add blockingPointsHash s.sid bpt; - blockingPoints := bpt :: !blockingPoints; - Queue.add bpt blockingPointsNew; - bpt - - -type action = - Process of stmt * node - | Next of stmt * node - | Return of node - -let getStmtNode (s: stmt) : node option = - match s.skind with - Instr instrs -> begin - let len = List.length instrs in - if len > 0 then - match List.nth instrs (len - 1) with - Call (_, Lval (Var vi, NoOffset), args, _) -> - Some (getFunctionNode vi.vname) - | Call (_, e, _, _) -> (* Calling a function pointer *) - Some (getFunctionPtrNode (typeOf e)) - | _ -> - None - else - None - end - | _ -> None - -let addBlockingPointEdge (bptFrom: blockpt) (bptTo: blockpt) : unit = - if not (List.exists (fun bpt -> bpt = bptTo) bptFrom.leadsto) then - bptFrom.leadsto <- bptTo :: bptFrom.leadsto - -let findBlockingPointEdges (bpt: blockpt) : unit = - let seenStmts = Hashtbl.create 117 in - let worklist = Queue.create () in - Queue.add (Next (bpt.point, getFunctionNode bpt.infun)) worklist; - while Queue.length worklist > 0 do - let act = Queue.take worklist in - match act with - Process (curStmt, curNode) -> begin - Hashtbl.add seenStmts curStmt.sid (); - match getStmtNode curStmt with - Some node -> begin - if debug then - ignore (E.log "processing node %s\n" node.name); - match node.bkind with - NoBlock -> - Queue.add (Next (curStmt, curNode)) worklist - | BlockTrans -> begin - let processFundec (fd: fundec) : unit = - let s = List.hd fd.sbody.bstmts in - if not (Hashtbl.mem seenStmts s.sid) then - let n = getFunctionNode fd.svar.vname in - Queue.add (Process (s, n)) worklist - in - match node.fds with - Some fd -> - processFundec fd - | None -> - List.iter - (fun n -> - match n.fds with - Some fd -> processFundec fd - | None -> E.s (bug "expected fundec")) - node.succs - end - | BlockPoint -> - addBlockingPointEdge bpt - (getBlockPt curStmt node.name curNode.name) - | EndPoint -> - addBlockingPointEdge bpt endPt - end - | _ -> - Queue.add (Next (curStmt, curNode)) worklist - end - | Next (curStmt, curNode) -> begin - match curStmt.Cil.succs with - [] -> - if debug then - ignore (E.log "hit end of %s\n" curNode.name); - Queue.add (Return curNode) worklist - | _ -> - List.iter (fun s -> - if not (Hashtbl.mem seenStmts s.sid) then - Queue.add (Process (s, curNode)) worklist) - curStmt.Cil.succs - end - | Return curNode when curNode.bkind = NoBlock -> - () - | Return curNode when curNode.name = !startName -> - addBlockingPointEdge bpt endPt - | Return curNode -> - List.iter (fun (s, n) -> if n.bkind <> NoBlock then - Queue.add (Next (s, n)) worklist) - curNode.predstmts; - List.iter (fun n -> if n.fptr then - Queue.add (Return n) worklist) - curNode.preds - done - -let markYieldPoints (n: node) : unit = - let rec markNode (n: node) : unit = - if n.bkind = NoBlock then - match n.origkind with - BlockTrans -> - if n.expand || n.fptr then begin - n.bkind <- BlockTrans; - List.iter markNode n.succs - end else begin - n.bkind <- BlockPoint - end - | _ -> - n.bkind <- n.origkind - in - Hashtbl.iter (fun _ n -> n.bkind <- NoBlock) functionNodes; - Hashtbl.iter (fun _ n -> n.bkind <- NoBlock) functionPtrNodes; - markNode n - -let makeBlockingGraph (start: node) = - let startStmt = - match start.fds with - Some fd -> List.hd fd.sbody.bstmts - | None -> E.s (bug "expected fundec") - in - curId := 1; - startName := start.name; - blockingPoints := [endPt]; - Queue.clear blockingPointsNew; - Hashtbl.clear blockingPointsHash; - ignore (getBlockPt startStmt start.name start.name); - while Queue.length blockingPointsNew > 0 do - let bpt = Queue.take blockingPointsNew in - findBlockingPointEdges bpt; - done - -let dumpBlockingGraph () = - List.iter - (fun bpt -> - if bpt.id < 2 then begin - ignore (E.log "bpt %d (%s): " bpt.id bpt.callfun) - end else begin - ignore (E.log "bpt %d (%s in %s): " bpt.id bpt.callfun bpt.infun) - end; - List.iter (fun bpt -> ignore (E.log "%d " bpt.id)) bpt.leadsto; - ignore (E.log "\n")) - !blockingPoints; - ignore (E.log "\n") - -let beforeFun = - makeGlobalVar "before_bg_node" - (TFun (voidType, Some [("node_idx", intType, []); - ("num_edges", intType, [])], - false, [])) - -let initFun = - makeGlobalVar "init_blocking_graph" - (TFun (voidType, Some [("num_nodes", intType, [])], - false, [])) - -let fingerprintVar = - let vi = makeGlobalVar "stack_fingerprint" intType in - vi.vstorage <- Extern; - vi - -let startNodeAddrs = - let vi = makeGlobalVar "start_node_addrs" (TPtr (voidPtrType, [])) in - vi.vstorage <- Extern; - vi - -let startNodeStacks = - let vi = makeGlobalVar "start_node_stacks" (TPtr (intType, [])) in - vi.vstorage <- Extern; - vi - -let startNodeAddrsArray = - makeGlobalVar "start_node_addrs_array" (TArray (voidPtrType, None, [])) - -let startNodeStacksArray = - makeGlobalVar "start_node_stacks_array" (TArray (intType, None, [])) - -let insertInstr (newInstr: instr) (s: stmt) : unit = - match s.skind with - Instr instrs -> - let rec insert (instrs: instr list) : instr list = - match instrs with - [] -> E.s (bug "instr list does not end with call\n") - | [Call _] -> newInstr :: instrs - | i :: rest -> i :: (insert rest) - in - s.skind <- Instr (insert instrs) - | _ -> - E.s (bug "instr stmt expected\n") - -let instrumentBlockingPoints () = - List.iter - (fun bpt -> - if bpt.id > 1 then - let arg1 = integer bpt.id in - let arg2 = integer (List.length bpt.leadsto) in - let call = Call (None, Lval (var beforeFun), - [arg1; arg2], locUnknown) in - insertInstr call bpt.point; - addCall (getFunctionNode bpt.infun) - (getFunctionNode beforeFun.vname) None) - !blockingPoints - - -let startNodes : node list ref = ref [] - -let makeAndDumpBlockingGraphs () : unit = - if List.length !startNodes > 1 then - E.s (unimp "We can't handle more than one start node right now.\n"); - List.iter - (fun n -> - markYieldPoints n; - (*dumpFunctionCallGraph n;*) - makeBlockingGraph n; - dumpBlockingGraph (); - instrumentBlockingPoints ()) - !startNodes - - -let pragmas : (string, int) Hashtbl.t = Hashtbl.create 13 - -let gatherPragmas (f: file) : unit = - List.iter - (function - GPragma (Attr ("stacksize", [AStr s; AInt n]), _) -> - Hashtbl.add pragmas s n - | _ -> ()) - f.globals - - -let blockingNodes : node list ref = ref [] - -let markBlockingFunctions () : unit = - let rec markFunction (n: node) : unit = - if debug then - ignore (E.log "marking %s\n" n.name); - if n.origkind = NoBlock then begin - n.origkind <- BlockTrans; - List.iter markFunction n.preds; - end - in - List.iter (fun n -> List.iter markFunction n.preds) !blockingNodes - -let hasFunctionTypeAttribute (n: string) (t: typ) : bool = - let _, _, _, a = splitFunctionType t in - hasAttribute n a - -let markVar (vi: varinfo) : unit = - let node = getFunctionNode vi.vname in - if node.origkind = NoBlock then begin - if hasAttribute "yield" vi.vattr then begin - node.origkind <- BlockPoint; - blockingNodes := node :: !blockingNodes; - end else if hasFunctionTypeAttribute "noreturn" vi.vtype then begin - node.origkind <- EndPoint; - end else if hasAttribute "expand" vi.vattr then begin - node.expand <- true; - end - end; - begin - try - node.stacksize <- Hashtbl.find pragmas node.name - with Not_found -> begin - match filterAttributes "stacksize" vi.vattr with - (Attr (_, [AInt n])) :: _ when n > node.stacksize -> - node.stacksize <- n - | _ -> () - end - end - -let makeFunctionCallGraph (f: Cil.file) : unit = - Hashtbl.clear functionNodes; - (* Scan the file and construct the control-flow graph *) - List.iter - (function - GFun(fdec, _) -> - let curNode = getFunctionNode fdec.svar.vname in - if fdec.svar.vaddrof then begin - addCall (getFunctionPtrNode fdec.svar.vtype) - curNode None; - end; - if hasAttribute "start" fdec.svar.vattr then begin - startNodes := curNode :: !startNodes; - end; - markVar fdec.svar; - curNode.fds <- Some fdec; - let vis = new findCallsVisitor curNode in - ignore (visitCilBlock vis fdec.sbody) - - | GVarDecl(vi, _) when isFunctionType vi.vtype -> - (* TODO: what if we take the addr of an extern? *) - markVar vi - - | _ -> ()) - f.globals - -let makeStartNodeLinks () : unit = - addCall startNode (getFunctionNode "main") None; - List.iter (fun n -> addCall startNode n None) !startNodes - -let funType (ret_t: typ) (args: (string * typ) list) = - TFun(ret_t, - Some (List.map (fun (n,t) -> (n, t, [])) args), - false, []) - -class instrumentClass = object - inherit nopCilVisitor - - val mutable curNode : node ref = ref (getFunctionNode "main") - val mutable seenRet : bool ref = ref false - - val mutable funId : int ref = ref 0 - - method vfunc (fdec: fundec) : fundec visitAction = begin - (* Remember the current function. *) - curNode := getFunctionNode fdec.svar.vname; - seenRet := false; - funId := Random.bits (); - (* Add useful locals. *) - ignore (makeLocalVar fdec "savesp" voidPtrType); - ignore (makeLocalVar fdec "savechunk" voidPtrType); - ignore (makeLocalVar fdec "savebottom" voidPtrType); - (* Add macro for function entry when we're done. *) - let addEntryNode (fdec: fundec) : fundec = - if not !seenRet then E.s (bug "didn't find a return statement"); - let node = getFunctionNode fdec.svar.vname in - if fingerprintAll || node.origkind <> NoBlock then begin - let fingerprintSet = - Set (var fingerprintVar, BinOp (BXor, Lval (var fingerprintVar), - integer !funId, intType), - locUnknown) - in - fdec.sbody.bstmts <- mkStmtOneInstr fingerprintSet :: fdec.sbody.bstmts - end; - let nodeFun = emptyFunction ("NODE_CALL_"^(string_of_int node.nodeid)) in - let nodeCall = Call (None, Lval (var nodeFun.svar), [], locUnknown) in - nodeFun.svar.vtype <- funType voidType []; - nodeFun.svar.vstorage <- Static; - fdec.sbody.bstmts <- mkStmtOneInstr nodeCall :: fdec.sbody.bstmts; - fdec - in - ChangeDoChildrenPost (fdec, addEntryNode) - end - - method vstmt (s: stmt) : stmt visitAction = begin - begin - match s.skind with - Instr instrs -> begin - let instrumentNode (callNode: node) : unit = - (* Make calls to macros. *) - let suffix = "_" ^ (string_of_int !curNode.nodeid) ^ - "_" ^ (string_of_int callNode.nodeid) - in - let beforeFun = emptyFunction ("BEFORE_CALL" ^ suffix) in - let beforeCall = Call (None, Lval (var beforeFun.svar), - [], locUnknown) in - beforeFun.svar.vtype <- funType voidType []; - beforeFun.svar.vstorage <- Static; - let afterFun = emptyFunction ("AFTER_CALL" ^ suffix) in - let afterCall = Call (None, Lval (var afterFun.svar), - [], locUnknown) in - afterFun.svar.vtype <- funType voidType []; - afterFun.svar.vstorage <- Static; - (* Insert instrumentation around call site. *) - let rec addCalls (is: instr list) : instr list = - match is with - [call] -> [beforeCall; call; afterCall] - | cur :: rest -> cur :: addCalls rest - | [] -> E.s (bug "expected list of non-zero length") - in - s.skind <- Instr (addCalls instrs) - in - (* If there's a call site here, instrument it. *) - let len = List.length instrs in - if len > 0 then begin - match List.nth instrs (len - 1) with - Call (_, Lval (Var vi, NoOffset), _, _) -> - (* - if (try String.sub vi.vname 0 10 <> "NODE_CALL_" - with Invalid_argument _ -> true) then -*) - instrumentNode (getFunctionNode vi.vname) - | Call (_, e, _, _) -> (* Calling a function pointer *) - instrumentNode (getFunctionPtrNode (typeOf e)) - | _ -> () - end; - DoChildren - end - | Cil.Return _ -> begin - if !seenRet then E.s (bug "found multiple returns"); - seenRet := true; - if fingerprintAll || !curNode.origkind <> NoBlock then begin - let fingerprintSet = - Set (var fingerprintVar, BinOp (BXor, Lval (var fingerprintVar), - integer !funId, intType), - locUnknown) - in - s.skind <- Block (mkBlock [mkStmtOneInstr fingerprintSet; - mkStmt s.skind]); - end; - SkipChildren - end - | _ -> DoChildren - end - end -end - -let makeStartNodeTable (globs: global list) : global list = - if List.length !startNodes = 0 then - globs - else - let addrInitInfo = { init = None } in - let stackInitInfo = { init = None } in - let rec processNode (nodes: node list) (i: int) = - match nodes with - node :: rest -> - let curGlobs, addrInit, stackInit = processNode rest (i + 1) in - let fd = - match node.fds with - Some fd -> fd - | None -> E.s (bug "expected fundec") - in - let stack = - makeGlobalVar ("NODE_STACK_" ^ (string_of_int node.nodeid)) intType - in - GVarDecl (fd.svar, locUnknown) :: curGlobs, - ((Index (integer i, NoOffset), SingleInit (mkAddrOf (var fd.svar))) :: - addrInit), - ((Index (integer i, NoOffset), SingleInit (Lval (var stack))) :: - stackInit) - | [] -> (GVarDecl (startNodeAddrs, locUnknown) :: - GVarDecl (startNodeStacks, locUnknown) :: - GVar (startNodeAddrsArray, addrInitInfo, locUnknown) :: - GVar (startNodeStacksArray, stackInitInfo, locUnknown) :: - []), - [Index (integer i, NoOffset), SingleInit zero], - [Index (integer i, NoOffset), SingleInit zero] - in - let newGlobs, addrInit, stackInit = processNode !startNodes 0 in - addrInitInfo.init <- - Some (CompoundInit (TArray (voidPtrType, None, []), addrInit)); - stackInitInfo.init <- - Some (CompoundInit (TArray (intType, None, []), stackInit)); - let file = { fileName = "startnode.h"; globals = newGlobs; - globinit = None; globinitcalled = false; } in - let channel = open_out file.fileName in - dumpFile defaultCilPrinter channel file; - close_out channel; - GText ("#include \"" ^ file.fileName ^ "\"") :: globs - -let instrumentProgram (f: file) : unit = - (* Add function prototypes. *) - f.globals <- makeStartNodeTable f.globals; - f.globals <- GText ("#include \"stack.h\"") :: - GVarDecl (initFun, locUnknown) :: - GVarDecl (beforeFun, locUnknown) :: - GVarDecl (fingerprintVar, locUnknown) :: - f.globals; - (* Add instrumentation to call sites. *) - visitCilFile ((new instrumentClass) :> cilVisitor) f; - (* Force creation of this node. *) - ignore (getFunctionNode beforeFun.vname); - (* Add initialization call to main(). *) - let mainNode = getFunctionNode "main" in - match mainNode.fds with - Some fdec -> - let arg1 = integer (List.length !blockingPoints) in - let initInstr = Call (None, Lval (var initFun), [arg1], locUnknown) in - let addrsInstr = - Set (var startNodeAddrs, StartOf (var startNodeAddrsArray), - locUnknown) - in - let stacksInstr = - Set (var startNodeStacks, StartOf (var startNodeStacksArray), - locUnknown) - in - let newStmt = - if List.length !startNodes = 0 then - mkStmtOneInstr initInstr - else - mkStmt (Instr [addrsInstr; stacksInstr; initInstr]) - in - fdec.sbody.bstmts <- newStmt :: fdec.sbody.bstmts; - addCall mainNode (getFunctionNode initFun.vname) None - | None -> - E.s (bug "expected main fundec") - - - -let feature : featureDescr = - { fd_name = "FCG"; - fd_enabled = ref false; - fd_description = "computing and printing a static call graph"; - fd_extraopt = []; - fd_doit = - (function (f : file) -> - Random.init 0; (* Use the same seed so that results are predictable. *) - gatherPragmas f; - makeFunctionCallGraph f; - makeStartNodeLinks (); - markBlockingFunctions (); - (* makeAndDumpBlockingGraphs (); *) - instrumentProgram f; - dumpFunctionCallGraphToFile ()); - fd_post_check = true; - } diff --git a/cil/src/ext/blockinggraph.mli b/cil/src/ext/blockinggraph.mli deleted file mode 100644 index 72f9ba7..0000000 --- a/cil/src/ext/blockinggraph.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* This module finds and analyzes yield points. *) - -val feature: Cil.featureDescr diff --git a/cil/src/ext/callgraph.ml b/cil/src/ext/callgraph.ml deleted file mode 100644 index 58472ac..0000000 --- a/cil/src/ext/callgraph.ml +++ /dev/null @@ -1,250 +0,0 @@ -(* callgraph.ml *) -(* code for callgraph.mli *) - -(* see copyright notice at end of this file *) - -open Cil -open Trace -open Printf -module P = Pretty -module IH = Inthash -module H = Hashtbl -module E = Errormsg - -(* ------------------- interface ------------------- *) -(* a call node describes the local calling structure for a - * single function: which functions it calls, and which - * functions call it *) -type callnode = { - (* An id *) - cnid: int; - - (* the function this node describes *) - cnInfo: nodeinfo; - - (* set of functions this one calls, indexed by the node id *) - cnCallees: callnode IH.t; - - (* set of functions that call this one , indexed by the node id *) - cnCallers: callnode IH.t; -} - -and nodeinfo = - NIVar of varinfo * bool ref - (* Node corresponding to a function. If the boolean - * is true, then the function is defined, otherwise - * it is external *) - - | NIIndirect of string (* Indirect nodes have a string associated to them. - * These strings must be invalid function names *) - * varinfo list ref - (* A list of functions that this indirect node might - * denote *) - -let nodeName (n: nodeinfo) : string = - match n with - NIVar (v, _) -> v.vname - | NIIndirect (n, _) -> n - -(* a call graph is a hashtable, mapping a function name to - * the node which describes that function's call structure *) -type callgraph = - (string, callnode) Hashtbl.t - -(* given the name of a function, retrieve its callnode; this will create a - * node if one doesn't already exist. Will use the given nodeinfo only when - * creating nodes. *) -let nodeId = ref 0 -let getNodeByName (cg: callgraph) (ni: nodeinfo) : callnode = - let name = nodeName ni in - try - H.find cg name - with Not_found -> ( - (* make a new node *) - let ret:callnode = { - cnInfo = ni; - cnid = !nodeId; - cnCallees = IH.create 5; - cnCallers = IH.create 5; - } - in - incr nodeId; - (* add it to the table, then return it *) - H.add cg name ret; - ret - ) - -(* Get the node for a variable *) -let getNodeForVar (cg: callgraph) (v: varinfo) : callnode = - getNodeByName cg (NIVar (v, ref false)) - -let getNodeForIndirect (cg: callgraph) (e: exp) : callnode = - getNodeByName cg (NIIndirect ("", ref [])) - - -(* Find the name of an indirect node that a function whose address is taken - * belongs *) -let markFunctionAddrTaken (cg: callgraph) (f: varinfo) : unit = - (* - ignore (E.log "markFunctionAddrTaken %s\n" f.vname); - *) - let n = getNodeForIndirect cg (AddrOf (Var f, NoOffset)) in - match n.cnInfo with - NIIndirect (_, r) -> r := f :: !r - | _ -> assert false - - - -class cgComputer (graph: callgraph) = object(self) - inherit nopCilVisitor - - (* the current function we're in, so when we visit a call node - * we know who is the caller *) - val mutable curFunc: callnode option = None - - - (* begin visiting a function definition *) - method vfunc (f:fundec) : fundec visitAction = begin - (trace "callgraph" (P.dprintf "entering function %s\n" f.svar.vname)); - let node = getNodeForVar graph f.svar in - (match node.cnInfo with - NIVar (v, r) -> r := true - | _ -> assert false); - curFunc <- (Some node); - DoChildren - end - - (* visit an instruction; we're only interested in calls *) - method vinst (i:instr) : instr list visitAction = begin - (*(trace "callgraph" (P.dprintf "visiting instruction: %a\n" dn_instr i));*) - let caller : callnode = - match curFunc with - None -> assert false - | Some c -> c - in - let callerName: string = nodeName caller.cnInfo in - (match i with - Call(_,f,_,_) -> ( - let callee: callnode = - match f with - | Lval(Var(vi),NoOffset) -> - (trace "callgraph" (P.dprintf "I see a call by %s to %s\n" - callerName vi.vname)); - getNodeForVar graph vi - - | _ -> - (trace "callgraph" (P.dprintf "indirect call: %a\n" - dn_instr i)); - getNodeForIndirect graph f - in - - (* add one entry to each node's appropriate list *) - IH.replace caller.cnCallees callee.cnid callee; - IH.replace callee.cnCallers caller.cnid caller - ) - - | _ -> ()); (* ignore other kinds instructions *) - - DoChildren - end - - method vexpr (e: exp) = - (match e with - AddrOf (Var fv, NoOffset) when isFunctionType fv.vtype -> - markFunctionAddrTaken graph fv - | _ -> ()); - - DoChildren -end - -let computeGraph (f:file) : callgraph = begin - let graph = H.create 37 in - let obj:cgComputer = new cgComputer graph in - - (* visit the whole file, computing the graph *) - visitCilFileSameGlobals (obj :> cilVisitor) f; - - - (* return the computed graph *) - graph -end - -let printGraph (out:out_channel) (g:callgraph) : unit = begin - let printEntry _ (n:callnode) : unit = - let name = nodeName n.cnInfo in - (Printf.fprintf out " %s" name) - in - - let printCalls (node:callnode) : unit = - (fprintf out " calls:"); - (IH.iter printEntry node.cnCallees); - (fprintf out "\n is called by:"); - (IH.iter printEntry node.cnCallers); - (fprintf out "\n") - in - - H.iter (fun (name: string) (node: callnode) -> - match node.cnInfo with - NIVar (v, def) -> - (fprintf out "%s (%s):\n" - v.vname (if !def then "defined" else "external")); - printCalls node - - | NIIndirect (n, funcs) -> - fprintf out "Indirect %s:\n" n; - fprintf out " possible aliases: "; - List.iter (fun a -> fprintf out "%s " a.vname) !funcs; - fprintf out "\n" - - ) - - g - end - -let doCallGraph = ref false - -let feature : featureDescr = - { fd_name = "callgraph"; - fd_enabled = doCallGraph; - fd_description = "generation of a static call graph"; - fd_extraopt = []; - fd_doit = - (function (f: file) -> - let graph:callgraph = computeGraph f in - printGraph stdout graph); - fd_post_check = false; - } - - -(* - * - * Copyright (c) 2001-2002 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * Ben Liblit liblit@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) diff --git a/cil/src/ext/callgraph.mli b/cil/src/ext/callgraph.mli deleted file mode 100644 index bc76018..0000000 --- a/cil/src/ext/callgraph.mli +++ /dev/null @@ -1,123 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(* callgraph.mli *) -(* compute a static call graph *) - -(* module maintainer: scott *) -(* see copyright notice at end of this file *) - - -(* ------------------ types ------------------- *) -(* a call node describes the local calling structure for a - * single function: which functions it calls, and which - * functions call it *) -type callnode = { - (* An id *) - cnid: int; - - (* the function this node describes *) - cnInfo: nodeinfo; - - (* set of functions this one calls, indexed by the node id *) - cnCallees: callnode Inthash.t; - - (* set of functions that call this one , indexed by the node id *) - cnCallers: callnode Inthash.t; -} - -and nodeinfo = - NIVar of Cil.varinfo * bool ref - (* Node corresponding to a function. If the boolean - * is true, then the function is defined, otherwise - * it is external *) - - | NIIndirect of string (* Indirect nodes have a string associated to them. - * These strings must be invalid function names *) - * Cil.varinfo list ref - (* A list of functions that this indirect node might - * denote *) - - -val nodeName: nodeinfo -> string - -(* a call graph is a hashtable, mapping a function name to - * the node which describes that function's call structure *) -type callgraph = - (string, callnode) Hashtbl.t - - -(* ----------------- functions ------------------- *) -(* given a CIL file, compute its static call graph *) -val computeGraph : Cil.file -> callgraph - -(* print the callgraph in a human-readable format to a channel *) -val printGraph : out_channel -> callgraph -> unit - - -val feature: Cil.featureDescr -(* - * - * Copyright (c) 2001-2002 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * Ben Liblit liblit@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) diff --git a/cil/src/ext/canonicalize.ml b/cil/src/ext/canonicalize.ml deleted file mode 100644 index a75deea..0000000 --- a/cil/src/ext/canonicalize.ml +++ /dev/null @@ -1,292 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - - -(************************************************************************ - * canonicalize performs several transformations to correct differences - * between C and C++, so that the output is (hopefully) valid C++ code. - * This is incomplete -- certain fixes which are necessary - * for some programs are not yet implemented. - * - * #1) C allows global variables to have multiple declarations and multiple - * (equivalent) definitions. This transformation removes all but one - * declaration and all but one definition. - * - * #2) Any variables that use C++ keywords as identifiers are renamed. - * - * #3) __inline is #defined to inline, and __restrict is #defined to nothing. - * - * #4) C allows function pointers with no specified arguments to be used on - * any argument list. To make C++ accept this code, we insert a cast - * from the function pointer to a type that matches the arguments. Of - * course, this does nothing to guarantee that the pointer actually has - * that type. - * - * #5) Makes casts from int to enum types explicit. (CIL changes enum - * constants to int constants, but doesn't use a cast.) - * - ************************************************************************) - -open Cil -module E = Errormsg -module H = Hashtbl - -(* For transformation #1. Stores all variable definitions in the file. *) -let varDefinitions: (varinfo, global) H.t = H.create 111 - - -class canonicalizeVisitor = object(self) - inherit nopCilVisitor - val mutable currentFunction: fundec = Cil.dummyFunDec; - - (* A hashtable to prevent duplicate declarations. *) - val alreadyDeclared: (varinfo, unit) H.t = H.create 111 - val alreadyDefined: (varinfo, unit) H.t = H.create 111 - - (* move variable declarations around *) - method vglob g = match g with - GVar(v, ({init = Some _} as inito), l) -> - (* A definition. May have been moved to an earlier position. *) - if H.mem alreadyDefined v then begin - ignore (E.warn "Duplicate definition of %s at %a.\n" - v.vname d_loc !currentLoc); - ChangeTo [] (* delete from here. *) - end else begin - H.add alreadyDefined v (); - if H.mem alreadyDeclared v then begin - (* Change the earlier declaration to Extern *) - let oldS = v.vstorage in - ignore (E.log "changing storage of %s from %a\n" - v.vname d_storage oldS); - v.vstorage <- Extern; - let newv = {v with vstorage = oldS} in - ChangeDoChildrenPost([GVar(newv, inito, l)], (fun g -> g) ) - end else - DoChildren - end - | GVar(v, {init=None}, l) - | GVarDecl(v, l) when not (isFunctionType v.vtype) -> begin - (* A declaration. May have been moved to an earlier position. *) - if H.mem alreadyDefined v || H.mem alreadyDeclared v then - ChangeTo [] (* delete from here. *) - else begin - H.add alreadyDeclared v (); - DoChildren - end - end - | GFun(f, l) -> - currentFunction <- f; - DoChildren - | _ -> - DoChildren - -(* #2. rename any identifiers whose names are C++ keywords *) - method vvdec v = - match v.vname with - | "bool" - | "catch" - | "cdecl" - | "class" - | "const_cast" - | "delete" - | "dynamic_cast" - | "explicit" - | "export" - | "false" - | "friend" - | "mutable" - | "namespace" - | "new" - | "operator" - | "pascal" - | "private" - | "protected" - | "public" - | "register" - | "reinterpret_cast" - | "static_cast" - | "template" - | "this" - | "throw" - | "true" - | "try" - | "typeid" - | "typename" - | "using" - | "virtual" - | "wchar_t"-> - v.vname <- v.vname ^ "__cil2cpp"; - DoChildren - | _ -> DoChildren - - method vinst i = -(* #5. If an assignment or function call uses expressions as enum values, - add an explicit cast. *) - match i with - Set (dest, exp, l) -> begin - let typeOfDest = typeOfLval dest in - match unrollType typeOfDest with - TEnum _ -> (* add an explicit cast *) - let newI = Set(dest, mkCast exp typeOfDest, l) in - ChangeTo [newI] - | _ -> SkipChildren - end - | Call (dest, f, args, l) -> begin - let rt, formals, isva, attrs = splitFunctionType (typeOf f) in - if isva then - SkipChildren (* ignore vararg functions *) - else - match formals with - Some formals' -> begin - let newArgs = try - (*Iterate over the arguments, looking for formals that - expect enum types, and insert casts where necessary. *) - List.map2 - (fun (actual: exp) (formalName, formalType, _) -> - match unrollType formalType with - TEnum _ -> mkCast actual formalType - | _ -> actual) - args - formals' - with Invalid_argument _ -> - E.s (error "Number of arguments to %a doesn't match type.\n" - d_exp f) - in - let newI = Call(dest, f, newArgs, l) in - ChangeTo [newI] - end - | None -> begin - (* #4. No arguments were specified for this type. To fix this, infer the - type from the arguments that are used n this instruction, and insert - a cast to that type.*) - match f with - Lval(Mem(fp), off) -> - let counter: int ref = ref 0 in - let newFormals = List.map - (fun (actual:exp) -> - incr counter; - let formalName = "a" ^ (string_of_int !counter) in - (formalName, typeOf actual, []))(* (name,type,attrs) *) - args in - let newFuncPtrType = - TPtr((TFun (rt, Some newFormals, false, attrs)), []) in - let newFuncPtr = Lval(Mem(mkCast fp newFuncPtrType), off) in - ChangeTo [Call(dest, newFuncPtr, args, l)] - | _ -> - ignore (warn "cppcanon: %a has no specified arguments, but it's not a function pointer." d_exp f); - SkipChildren - end - end - | _ -> SkipChildren - - method vinit i = -(* #5. If an initializer uses expressions as enum values, - add an explicit cast. *) - match i with - SingleInit e -> DoChildren (* we don't handle simple initializers here, - because we don't know what type is expected. - This should be done in vglob if needed. *) - | CompoundInit(t, initList) -> - let changed: bool ref = ref false in - let initList' = List.map - (* iterate over the list, adding casts for any expression that - is expected to be an enum type. *) - (function - (Field(fi, off), SingleInit e) -> begin - match unrollType fi.ftype with - TEnum _ -> (* add an explicit cast *) - let newE = mkCast e fi.ftype in - changed := true; - (Field(fi, off), SingleInit newE) - | _ -> (* not enum, no cast needed *) - (Field(fi, off), SingleInit e) - end - | other -> - (* This is a more complicated initializer, and I don't think - it can have type enum. It's children might, though. *) - other) - initList in - if !changed then begin - (* There may be other casts needed in other parts of the - initialization, so do the children too. *) - ChangeDoChildrenPost(CompoundInit(t, initList'), (fun x -> x)) - end else - DoChildren - - -(* #5. If a function returns an enum type, add an explicit cast to the - return type. *) - method vstmt stmt = - (match stmt.skind with - Return (Some exp, l) -> begin - let typeOfDest, _, _, _ = - splitFunctionType currentFunction.svar.vtype in - match unrollType typeOfDest with - TEnum _ -> - stmt.skind <- Return (Some (mkCast exp typeOfDest), l) - | _ -> () - end - | _ -> ()); - DoChildren -end (* class canonicalizeVisitor *) - - - -(* Entry point for this extension *) -let canonicalize (f:file) = - visitCilFile (new canonicalizeVisitor) f; - - (* #3. Finally, add some #defines to change C keywords to their C++ - equivalents: *) - f.globals <- - GText( "#ifdef __cplusplus\n" - ^" #define __restrict\n" (* "restrict" doesn't work *) - ^" #define __inline inline\n" - ^"#endif") - ::f.globals - - - -let feature : featureDescr = - { fd_name = "canonicalize"; - fd_enabled = ref false; - fd_description = "fixing some C-isms so that the result is C++ compliant."; - fd_extraopt = []; - fd_doit = canonicalize; - fd_post_check = true; - } diff --git a/cil/src/ext/canonicalize.mli b/cil/src/ext/canonicalize.mli deleted file mode 100644 index 37bc0d8..0000000 --- a/cil/src/ext/canonicalize.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(************************************************************************ - * canonicalize performs several transformations to correct differences - * between C and C++, so that the output is (hopefully) valid C++ code. - * This is incomplete -- certain fixes which are necessary - * for some programs are not yet implemented. - * - * See canonicalize.ml for a list of changes. - * - ************************************************************************) - -val feature: Cil.featureDescr diff --git a/cil/src/ext/cfg.ml b/cil/src/ext/cfg.ml deleted file mode 100644 index 8b19c79..0000000 --- a/cil/src/ext/cfg.ml +++ /dev/null @@ -1,289 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Simon Goldsmith - * S.P Rahul, Aman Bhargava - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Authors: Aman Bhargava, S. P. Rahul *) -(* sfg: this stuff was stolen from optim.ml - the code to print the cfg as - a dot graph is mine *) - -open Pretty -open Cil -module E=Errormsg - -(* entry points: cfgFun, printCfgChannel, printCfgFilename *) - -(* known issues: - * -sucessors of if somehow end up with two edges each - *) - -(*------------------------------------------------------------*) -(* Notes regarding CFG computation: - 1) Initially only succs and preds are computed. sid's are filled in - later, in whatever order is suitable (e.g. for forward problems, reverse - depth-first postorder). - 2) If a stmt (return, break or continue) has no successors, then - function return must follow. - No predecessors means it is the start of the function - 3) We use the fact that initially all the succs and preds are assigned [] -*) - -(* Fill in the CFG info for the stmts in a block - next = succ of the last stmt in this block - break = succ of any Break in this block - cont = succ of any Continue in this block - None means the succ is the function return. It does not mean the break/cont - is invalid. We assume the validity has already been checked. -*) -(* At the end of CFG computation, - - numNodes = total number of CFG nodes - - length(nodeList) = numNodes -*) - -let numNodes = ref 0 (* number of nodes in the CFG *) -let nodeList : stmt list ref = ref [] (* All the nodes in a flat list *) (* ab: Added to change dfs from quadratic to linear *) -let start_id = ref 0 (* for unique ids across many functions *) - -(* entry point *) - -(** Compute a control flow graph for fd. Stmts in fd have preds and succs - filled in *) -let rec cfgFun (fd : fundec): int = - begin - numNodes := !start_id; - nodeList := []; - - cfgBlock fd.sbody None None None; - !numNodes - !start_id - end - - -and cfgStmts (ss: stmt list) - (next:stmt option) (break:stmt option) (cont:stmt option) = - match ss with - [] -> (); - | [s] -> cfgStmt s next break cont - | hd::tl -> - cfgStmt hd (Some (List.hd tl)) break cont; - cfgStmts tl next break cont - -and cfgBlock (blk: block) - (next:stmt option) (break:stmt option) (cont:stmt option) = - cfgStmts blk.bstmts next break cont - -(* Fill in the CFG info for a stmt - Meaning of next, break, cont should be clear from earlier comment -*) -and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) = - incr numNodes; - s.sid <- !numNodes; - nodeList := s :: !nodeList; (* Future traversals can be made in linear time. e.g. *) - if s.succs <> [] then - E.s (bug "CFG must be cleared before being computed!"); - let addSucc (n: stmt) = - if not (List.memq n s.succs) then - s.succs <- n::s.succs; - if not (List.memq s n.preds) then - n.preds <- s::n.preds - in - let addOptionSucc (n: stmt option) = - match n with - None -> () - | Some n' -> addSucc n' - in - let addBlockSucc (b: block) = - match b.bstmts with - [] -> addOptionSucc next - | hd::_ -> addSucc hd - in - match s.skind with - Instr _ -> addOptionSucc next - | Return _ -> () - | Goto (p,_) -> addSucc !p - | Break _ -> addOptionSucc break - | Continue _ -> addOptionSucc cont - | If (_, blk1, blk2, _) -> - (* The succs of If is [true branch;false branch] *) - addBlockSucc blk2; - addBlockSucc blk1; - cfgBlock blk1 next break cont; - cfgBlock blk2 next break cont - | Block b -> - addBlockSucc b; - cfgBlock b next break cont - | Switch(_,blk,l,_) -> - List.iter addSucc (List.rev l); (* Add successors in order *) - (* sfg: if there's no default, need to connect s->next *) - if not (List.exists - (fun stmt -> List.exists - (function Default _ -> true | _ -> false) - stmt.labels) - l) - then - addOptionSucc next; - cfgBlock blk next next cont -(* - | Loop(blk,_,_,_) -> -*) - | While(_,blk,_) - | DoWhile(_,blk,_) - | For(_,_,_,blk,_) -> - addBlockSucc blk; - cfgBlock blk (Some s) next (Some s) - (* Since all loops have terminating condition true, we don't put - any direct successor to stmt following the loop *) - | TryExcept _ | TryFinally _ -> - E.s (E.unimp "try/except/finally") - -(*------------------------------------------------------------*) - -(**************************************************************) -(* do something for all stmts in a fundec *) - -let rec forallStmts (todo) (fd : fundec) = - begin - fasBlock todo fd.sbody; - end - -and fasBlock (todo) (b : block) = - List.iter (fasStmt todo) b.bstmts - -and fasStmt (todo) (s : stmt) = - begin - ignore(todo s); - match s.skind with - | Block b -> fasBlock todo b - | If (_, tb, fb, _) -> (fasBlock todo tb; fasBlock todo fb) - | Switch (_, b, _, _) -> fasBlock todo b -(* - | Loop (b, _, _, _) -> fasBlock todo b -*) - | While (_, b, _) -> fasBlock todo b - | DoWhile (_, b, _) -> fasBlock todo b - | For (_, _, _, b, _) -> fasBlock todo b - | (Return _ | Break _ | Continue _ | Goto _ | Instr _) -> () - | TryExcept _ | TryFinally _ -> E.s (E.unimp "try/except/finally") - end -;; - -(**************************************************************) -(* printing the control flow graph - you have to compute it first *) - -let d_cfgnodename () (s : stmt) = - dprintf "%d" s.sid - -let d_cfgnodelabel () (s : stmt) = - let label = - begin - match s.skind with - | If (e, _, _, _) -> "if" (*sprint ~width:999 (dprintf "if %a" d_exp e)*) -(* - | Loop _ -> "loop" -*) - | While _ -> "while" - | DoWhile _ -> "dowhile" - | For _ -> "for" - | Break _ -> "break" - | Continue _ -> "continue" - | Goto _ -> "goto" - | Instr _ -> "instr" - | Switch _ -> "switch" - | Block _ -> "block" - | Return _ -> "return" - | TryExcept _ -> "try-except" - | TryFinally _ -> "try-finally" - end in - dprintf "%d: %s" s.sid label - -let d_cfgedge (src) () (dest) = - dprintf "%a -> %a" - d_cfgnodename src - d_cfgnodename dest - -let d_cfgnode () (s : stmt) = - dprintf "%a [label=\"%a\"]\n\t%a" - d_cfgnodename s - d_cfgnodelabel s - (d_list "\n\t" (d_cfgedge s)) s.succs - -(**********************************************************************) -(* entry points *) - -(** print control flow graph (in dot form) for fundec to channel *) -let printCfgChannel (chan : out_channel) (fd : fundec) = - let pnode (s:stmt) = fprintf chan "%a\n" d_cfgnode s in - begin - ignore (fprintf chan "digraph CFG_%s {\n" fd.svar.vname); - forallStmts pnode fd; - ignore(fprintf chan "}\n"); - end - -(** Print control flow graph (in dot form) for fundec to file *) -let printCfgFilename (filename : string) (fd : fundec) = - let chan = open_out filename in - begin - printCfgChannel chan fd; - close_out chan; - end - - -;; - -(**********************************************************************) - -let clearCFGinfo (fd : fundec) = - let clear s = - s.sid <- -1; - s.succs <- []; - s.preds <- []; - in - forallStmts clear fd - -let clearFileCFG (f : file) = - iterGlobals f (fun g -> - match g with GFun(fd,_) -> - clearCFGinfo fd - | _ -> ()) - -let computeFileCFG (f : file) = - iterGlobals f (fun g -> - match g with GFun(fd,_) -> - numNodes := cfgFun fd; - start_id := !start_id + !numNodes - | _ -> ()) diff --git a/cil/src/ext/cfg.mli b/cil/src/ext/cfg.mli deleted file mode 100644 index 19c5166..0000000 --- a/cil/src/ext/cfg.mli +++ /dev/null @@ -1,36 +0,0 @@ -(** Code to compute the control-flow graph of a function or file. - This will fill in the [preds] and [succs] fields of {!Cil.stmt} - - This is required for several other extensions, such as {!Dataflow}. -*) - -open Cil - - -(** Compute the CFG for an entire file, by calling cfgFun on each function. *) -val computeFileCFG: Cil.file -> unit - -(** clear the sid, succs, and preds fields of each statement. *) -val clearFileCFG: Cil.file -> unit - -(** Compute a control flow graph for fd. Stmts in fd have preds and succs - filled in *) -val cfgFun : fundec -> int - -(** clear the sid, succs, and preds fields of each statment in a function *) -val clearCFGinfo: Cil.fundec -> unit - -(** print control flow graph (in dot form) for fundec to channel *) -val printCfgChannel : out_channel -> fundec -> unit - -(** Print control flow graph (in dot form) for fundec to file *) -val printCfgFilename : string -> fundec -> unit - -(** Next statement id that will be assigned. *) -val start_id: int ref - -(** All of the nodes in a file. *) -val nodeList : stmt list ref - -(** number of nodes in the CFG *) -val numNodes : int ref diff --git a/cil/src/ext/ciltools.ml b/cil/src/ext/ciltools.ml deleted file mode 100755 index 78f1aaf..0000000 --- a/cil/src/ext/ciltools.ml +++ /dev/null @@ -1,228 +0,0 @@ -open Cil - -(* Contributed by Nathan Cooprider *) - -let isOne e = - isInteger e = Some Int64.one - - -(* written by Zach *) -let is_volatile_tp tp = - List.exists (function (Attr("volatile",_)) -> true - | _ -> false) (typeAttrs tp) - -(* written by Zach *) -let is_volatile_vi vi = - let vi_vol = - List.exists (function (Attr("volatile",_)) -> true - | _ -> false) vi.vattr in - let typ_vol = is_volatile_tp vi.vtype in - vi_vol || typ_vol - -(***************************************************************************** - * A collection of useful functions that were not already in CIL as far as I - * could tell. However, I have been surprised before . . . - ****************************************************************************) - -type sign = Signed | Unsigned - -exception Not_an_integer - -(***************************************************************************** - * A bunch of functions for accessing integers. Originally written for - * somebody who didn't know CIL and just wanted to mess with it at the - * OCaml level. - ****************************************************************************) - -let unbox_int_type (ye : typ) : (int * sign) = - let tp = unrollType ye in - let s = - match tp with - TInt (i, _) -> - if (isSigned i) then - Signed - else - Unsigned - | _ -> raise Not_an_integer - in - (bitsSizeOf tp), s - -(* depricated. Use isInteger directly instead *) -let unbox_int_exp (e : exp) : int64 = - match isInteger e with - None -> raise Not_an_integer - | Some (x) -> x - -let box_int_to_exp (n : int64) (ye : typ) : exp = - let tp = unrollType ye in - match tp with - TInt (i, _) -> - kinteger64 i n - | _ -> raise Not_an_integer - -let cil_to_ocaml_int (e : exp) : (int64 * int * sign) = - let v, s = unbox_int_type (typeOf e) in - unbox_int_exp (e), v, s - -exception Weird_bitwidth - -(* (int64 * int * sign) : exp *) -let ocaml_int_to_cil v n s = - let char_size = bitsSizeOf charType in - let int_size = bitsSizeOf intType in - let short_size = bitsSizeOf (TInt(IShort,[]))in - let long_size = bitsSizeOf longType in - let longlong_size = bitsSizeOf (TInt(ILongLong,[])) in - let i = - match s with - Signed -> - if (n = char_size) then - ISChar - else if (n = int_size) then - IInt - else if (n = short_size) then - IShort - else if (n = long_size) then - ILong - else if (n = longlong_size) then - ILongLong - else - raise Weird_bitwidth - | Unsigned -> - if (n = char_size) then - IUChar - else if (n = int_size) then - IUInt - else if (n = short_size) then - IUShort - else if (n = long_size) then - IULong - else if (n = longlong_size) then - IULongLong - else - raise Weird_bitwidth - in - kinteger64 i v - -(***************************************************************************** - * a couple of type functions that I thought would be useful: - ****************************************************************************) - -let rec isCompositeType tp = - match tp with - TComp _ -> true - | TPtr(x, _) -> isCompositeType x - | TArray(x,_,_) -> isCompositeType x - | TFun(x,_,_,_) -> isCompositeType x - | TNamed (x,_) -> isCompositeType x.ttype - | _ -> false - -(** START OF deepHasAttribute ************************************************) -let visited = ref [] -class attribute_checker target rflag = object (self) - inherit nopCilVisitor - method vtype t = - match t with - TComp(cinfo, a) -> - if(not (List.exists (fun x -> cinfo.cname = x) !visited )) then begin - visited := cinfo.cname :: !visited; - List.iter - (fun f -> - if (hasAttribute target f.fattr) then - rflag := true - else - ignore(visitCilType (new attribute_checker target rflag) - f.ftype)) cinfo.cfields; - end; - DoChildren - | TNamed(t1, a) -> - if(not (List.exists (fun x -> t1.tname = x) !visited )) then begin - visited := t1.tname :: !visited; - ignore(visitCilType (new attribute_checker target rflag) t1.ttype); - end; - DoChildren - | _ -> - DoChildren - method vattr (Attr(name,params)) = - if (name = target) then rflag := true; - DoChildren -end - -let deepHasAttribute s t = - let found = ref false in - visited := []; - ignore(visitCilType (new attribute_checker s found) t); - !found -(** END OF deepHasAttribute **************************************************) - -(** Stuff from ptranal, slightly modified ************************************) - -(***************************************************************************** - * A transformation to make every instruction be in its own statement. - ****************************************************************************) - -class callBBVisitor = object - inherit nopCilVisitor - - method vstmt s = - match s.skind with - Instr(il) -> begin - if (List.length il > 1) then - let list_of_stmts = List.map (fun one_inst -> - mkStmtOneInstr one_inst) il in - let block = mkBlock list_of_stmts in - s.skind <- Block block; - ChangeTo(s) - else - SkipChildren - end - | _ -> DoChildren - - method vvdec _ = SkipChildren - method vexpr _ = SkipChildren - method vlval _ = SkipChildren - method vtype _ = SkipChildren -end - -let one_instruction_per_statement f = - let thisVisitor = new callBBVisitor in - visitCilFileSameGlobals thisVisitor f - -(***************************************************************************** - * A transformation that gives each variable a unique identifier. - ****************************************************************************) - -class vidVisitor = object - inherit nopCilVisitor - val count = ref 0 - - method vvdec vi = - vi.vid <- !count ; - incr count ; SkipChildren -end - -let globally_unique_vids f = - let thisVisitor = new vidVisitor in - visitCilFileSameGlobals thisVisitor f - -(** End of stuff from ptranal ************************************************) - -class sidVisitor = object - inherit nopCilVisitor - val count = ref 0 - - method vstmt s = - s.sid <- !count ; - incr count ; - DoChildren -end - -let globally_unique_sids f = - let thisVisitor = new sidVisitor in - visitCilFileSameGlobals thisVisitor f - -(** Comparing expressions without a Out_of_memory error **********************) - -let compare_exp x y = - compare x y - diff --git a/cil/src/ext/dataflow.ml b/cil/src/ext/dataflow.ml deleted file mode 100755 index 7f28f84..0000000 --- a/cil/src/ext/dataflow.ml +++ /dev/null @@ -1,466 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -module IH = Inthash -module E = Errormsg - -open Cil -open Pretty - -(** A framework for data flow analysis for CIL code. Before using - this framework, you must initialize the Control-flow Graph for your - program, e.g using {!Cfg.computeFileCFG} *) - -type 't action = - Default (** The default action *) - | Done of 't (** Do not do the default action. Use this result *) - | Post of ('t -> 't) (** The default action, followed by the given - * transformer *) - -type 't stmtaction = - SDefault (** The default action *) - | SDone (** Do not visit this statement or its successors *) - | SUse of 't (** Visit the instructions and successors of this statement - as usual, but use the specified state instead of the - one that was passed to doStmt *) - -(* For if statements *) -type 't guardaction = - GDefault (** The default state *) - | GUse of 't (** Use this data for the branch *) - | GUnreachable (** The branch will never be taken. *) - - -(****************************************************************** - ********** - ********** FORWARDS - ********** - ********************************************************************) - -module type ForwardsTransfer = sig - val name: string (** For debugging purposes, the name of the analysis *) - - val debug: bool ref (** Whether to turn on debugging *) - - type t (** The type of the data we compute for each block start. May be - * imperative. *) - - val copy: t -> t - (** Make a deep copy of the data *) - - - val stmtStartData: t Inthash.t - (** For each statement id, the data at the start. Not found in the hash - * table means nothing is known about the state at this point. At the end - * of the analysis this means that the block is not reachable. *) - - val pretty: unit -> t -> Pretty.doc - (** Pretty-print the state *) - - val computeFirstPredecessor: Cil.stmt -> t -> t - (** Give the first value for a predecessors, compute the value to be set - * for the block *) - - val combinePredecessors: Cil.stmt -> old:t -> t -> t option - (** Take some old data for the start of a statement, and some new data for - * the same point. Return None if the combination is identical to the old - * data. Otherwise, compute the combination, and return it. *) - - val doInstr: Cil.instr -> t -> t action - (** The (forwards) transfer function for an instruction. The - * {!Cil.currentLoc} is set before calling this. The default action is to - * continue with the state unchanged. *) - - val doStmt: Cil.stmt -> t -> t stmtaction - (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} - * is set before calling this. The default action is to do the instructions - * in this statement, if applicable, and continue with the successors. *) - - val doGuard: Cil.exp -> t -> t guardaction - (** Generate the successor to an If statement assuming the given expression - * is nonzero. Analyses that don't need guard information can return - * GDefault; this is equivalent to returning GUse of the input. - * A return value of GUnreachable indicates that this half of the branch - * will not be taken and should not be explored. This will be called - * twice per If, once for "then" and once for "else". - *) - - val filterStmt: Cil.stmt -> bool - (** Whether to put this statement in the worklist. This is called when a - * block would normally be put in the worklist. *) - -end - - -module ForwardsDataFlow = - functor (T : ForwardsTransfer) -> - struct - - (** Keep a worklist of statements to process. It is best to keep a queue, - * because this way it is more likely that we are going to process all - * predecessors of a statement before the statement itself. *) - let worklist: Cil.stmt Queue.t = Queue.create () - - (** We call this function when we have encountered a statement, with some - * state. *) - let reachedStatement (s: stmt) (d: T.t) : unit = - (** see if we know about it already *) - E.pushContext (fun _ -> dprintf "Reached statement %d with %a" - s.sid T.pretty d); - let newdata: T.t option = - try - let old = IH.find T.stmtStartData s.sid in - match T.combinePredecessors s ~old:old d with - None -> (* We are done here *) - if !T.debug then - ignore (E.log "FF(%s): reached stmt %d with %a\n implies the old state %a\n" - T.name s.sid T.pretty d T.pretty old); - None - | Some d' -> begin - (* We have changed the data *) - if !T.debug then - ignore (E.log "FF(%s): weaken data for block %d: %a\n" - T.name s.sid T.pretty d'); - Some d' - end - with Not_found -> (* was bottom before *) - let d' = T.computeFirstPredecessor s d in - if !T.debug then - ignore (E.log "FF(%s): set data for block %d: %a\n" - T.name s.sid T.pretty d'); - Some d' - in - E.popContext (); - match newdata with - None -> () - | Some d' -> - IH.replace T.stmtStartData s.sid d'; - if T.filterStmt s && - not (Queue.fold (fun exists s' -> exists || s'.sid = s.sid) - false - worklist) then - Queue.add s worklist - - - (** Get the two successors of an If statement *) - let ifSuccs (s:stmt) : stmt * stmt = - let fstStmt blk = match blk.bstmts with - [] -> Cil.dummyStmt - | fst::_ -> fst - in - match s.skind with - If(e, b1, b2, _) -> - let thenSucc = fstStmt b1 in - let elseSucc = fstStmt b2 in - let oneFallthrough () = - let fallthrough = - List.filter - (fun s' -> thenSucc != s' && elseSucc != s') - s.succs - in - match fallthrough with - [] -> E.s (bug "Bad CFG: missing fallthrough for If.") - | [s'] -> s' - | _ -> E.s (bug "Bad CFG: multiple fallthrough for If.") - in - (* If thenSucc or elseSucc is Cil.dummyStmt, it's an empty block. - So the successor is the statement after the if *) - let stmtOrFallthrough s' = - if s' == Cil.dummyStmt then - oneFallthrough () - else - s' - in - (stmtOrFallthrough thenSucc, - stmtOrFallthrough elseSucc) - - | _-> E.s (bug "ifSuccs on a non-If Statement.") - - (** Process a statement *) - let processStmt (s: stmt) : unit = - currentLoc := get_stmtLoc s.skind; - if !T.debug then - ignore (E.log "FF(%s).stmt %d at %t\n" T.name s.sid d_thisloc); - - (* It must be the case that the block has some data *) - let init: T.t = - try T.copy (IH.find T.stmtStartData s.sid) - with Not_found -> - E.s (E.bug "FF(%s): processing block without data" T.name) - in - - (** See what the custom says *) - match T.doStmt s init with - SDone -> () - | (SDefault | SUse _) as act -> begin - let curr = match act with - SDefault -> init - | SUse d -> d - | SDone -> E.s (bug "SDone") - in - (* Do the instructions in order *) - let handleInstruction (s: T.t) (i: instr) : T.t = - currentLoc := get_instrLoc i; - - (* Now handle the instruction itself *) - let s' = - let action = T.doInstr i s in - match action with - | Done s' -> s' - | Default -> s (* do nothing *) - | Post f -> f s - in - s' - in - - let after: T.t = - match s.skind with - Instr il -> - (* Handle instructions starting with the first one *) - List.fold_left handleInstruction curr il - - | Goto _ | Break _ | Continue _ | If _ - | TryExcept _ | TryFinally _ - | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ - | Return _ | Block _ -> curr - in - currentLoc := get_stmtLoc s.skind; - - (* Handle If guards *) - let succsToReach = match s.skind with - If (e, _, _, _) -> begin - let not_e = UnOp(LNot, e, intType) in - let thenGuard = T.doGuard e after in - let elseGuard = T.doGuard not_e after in - if thenGuard = GDefault && elseGuard = GDefault then - (* this is the common case *) - s.succs - else begin - let doBranch succ guard = - match guard with - GDefault -> reachedStatement succ after - | GUse d -> reachedStatement succ d - | GUnreachable -> - if !T.debug then - ignore (E.log "FF(%s): Not exploring branch to %d\n" - T.name succ.sid); - - () - in - let thenSucc, elseSucc = ifSuccs s in - doBranch thenSucc thenGuard; - doBranch elseSucc elseGuard; - [] - end - end - | _ -> s.succs - in - (* Reach the successors *) - List.iter (fun s' -> reachedStatement s' after) succsToReach; - - end - - - - - (** Compute the data flow. Must have the CFG initialized *) - let compute (sources: stmt list) = - Queue.clear worklist; - List.iter (fun s -> Queue.add s worklist) sources; - - (** All initial stmts must have non-bottom data *) - List.iter (fun s -> - if not (IH.mem T.stmtStartData s.sid) then - E.s (E.error "FF(%s): initial stmt %d does not have data" - T.name s.sid)) - sources; - if !T.debug then - ignore (E.log "\nFF(%s): processing\n" - T.name); - let rec fixedpoint () = - if !T.debug && not (Queue.is_empty worklist) then - ignore (E.log "FF(%s): worklist= %a\n" - T.name - (docList (fun s -> num s.sid)) - (List.rev - (Queue.fold (fun acc s -> s :: acc) [] worklist))); - try - let s = Queue.take worklist in - processStmt s; - fixedpoint (); - with Queue.Empty -> - if !T.debug then - ignore (E.log "FF(%s): done\n\n" T.name) - in - fixedpoint () - - end - - - -(****************************************************************** - ********** - ********** BACKWARDS - ********** - ********************************************************************) -module type BackwardsTransfer = sig - val name: string (* For debugging purposes, the name of the analysis *) - - val debug: bool ref (** Whether to turn on debugging *) - - type t (** The type of the data we compute for each block start. In many - * presentations of backwards data flow analysis we maintain the - * data at the block end. This is not easy to do with JVML because - * a block has many exceptional ends. So we maintain the data for - * the statement start. *) - - val pretty: unit -> t -> Pretty.doc (** Pretty-print the state *) - - val stmtStartData: t Inthash.t - (** For each block id, the data at the start. This data structure must be - * initialized with the initial data for each block *) - - val combineStmtStartData: Cil.stmt -> old:t -> t -> t option - (** When the analysis reaches the start of a block, combine the old data - * with the one we have just computed. Return None if the combination is - * the same as the old data, otherwise return the combination. In the - * latter case, the predecessors of the statement are put on the working - * list. *) - - - val combineSuccessors: t -> t -> t - (** Take the data from two successors and combine it *) - - - val doStmt: Cil.stmt -> t action - (** The (backwards) transfer function for a branch. The {!Cil.currentLoc} is - * set before calling this. If it returns None, then we have some default - * handling. Otherwise, the returned data is the data before the branch - * (not considering the exception handlers) *) - - val doInstr: Cil.instr -> t -> t action - (** The (backwards) transfer function for an instruction. The - * {!Cil.currentLoc} is set before calling this. If it returns None, then we - * have some default handling. Otherwise, the returned data is the data - * before the branch (not considering the exception handlers) *) - - val filterStmt: Cil.stmt -> Cil.stmt -> bool - (** Whether to put this predecessor block in the worklist. We give the - * predecessor and the block whose predecessor we are (and whose data has - * changed) *) - -end - -module BackwardsDataFlow = - functor (T : BackwardsTransfer) -> - struct - - let getStmtStartData (s: stmt) : T.t = - try IH.find T.stmtStartData s.sid - with Not_found -> - E.s (E.bug "BF(%s): stmtStartData is not initialized for %d" - T.name s.sid) - - (** Process a statement and return true if the set of live return - * addresses on its entry has changed. *) - let processStmt (s: stmt) : bool = - if !T.debug then - ignore (E.log "FF(%s).stmt %d\n" T.name s.sid); - - - (* Find the state before the branch *) - currentLoc := get_stmtLoc s.skind; - let d: T.t = - match T.doStmt s with - Done d -> d - | (Default | Post _) as action -> begin - (* Do the default one. Combine the successors *) - let res = - match s.succs with - [] -> E.s (E.bug "You must doStmt for the statements with no successors") - | fst :: rest -> - List.fold_left (fun acc succ -> - T.combineSuccessors acc (getStmtStartData succ)) - (getStmtStartData fst) - rest - in - (* Now do the instructions *) - let res' = - match s.skind with - Instr il -> - (* Now scan the instructions in reverse order. This may - * Stack_overflow on very long blocks ! *) - let handleInstruction (i: instr) (s: T.t) : T.t = - currentLoc := get_instrLoc i; - (* First handle the instruction itself *) - let action = T.doInstr i s in - match action with - | Done s' -> s' - | Default -> s (* do nothing *) - | Post f -> f s - in - (* Handle instructions starting with the last one *) - List.fold_right handleInstruction il res - - | _ -> res - in - match action with - Post f -> f res' - | _ -> res' - end - in - - (* See if the state has changed. The only changes are that it may grow.*) - let s0 = getStmtStartData s in - - match T.combineStmtStartData s ~old:s0 d with - None -> (* The old data is good enough *) - false - - | Some d' -> - (* We have changed the data *) - if !T.debug then - ignore (E.log "BF(%s): set data for block %d: %a\n" - T.name s.sid T.pretty d'); - IH.replace T.stmtStartData s.sid d'; - true - - - (** Compute the data flow. Must have the CFG initialized *) - let compute (sinks: stmt list) = - let worklist: Cil.stmt Queue.t = Queue.create () in - List.iter (fun s -> Queue.add s worklist) sinks; - if !T.debug && not (Queue.is_empty worklist) then - ignore (E.log "\nBF(%s): processing\n" - T.name); - let rec fixedpoint () = - if !T.debug && not (Queue.is_empty worklist) then - ignore (E.log "BF(%s): worklist= %a\n" - T.name - (docList (fun s -> num s.sid)) - (List.rev - (Queue.fold (fun acc s -> s :: acc) [] worklist))); - try - let s = Queue.take worklist in - let changes = processStmt s in - if changes then begin - (* We must add all predecessors of block b, only if not already - * in and if the filter accepts them. *) - List.iter - (fun p -> - if not (Queue.fold (fun exists s' -> exists || p.sid = s'.sid) - false worklist) && - T.filterStmt p s then - Queue.add p worklist) - s.preds; - end; - fixedpoint (); - - with Queue.Empty -> - if !T.debug then - ignore (E.log "BF(%s): done\n\n" T.name) - in - fixedpoint (); - - end - - diff --git a/cil/src/ext/dataflow.mli b/cil/src/ext/dataflow.mli deleted file mode 100755 index e72c5db..0000000 --- a/cil/src/ext/dataflow.mli +++ /dev/null @@ -1,151 +0,0 @@ -(** A framework for data flow analysis for CIL code. Before using - this framework, you must initialize the Control-flow Graph for your - program, e.g using {!Cfg.computeFileCFG} *) - -type 't action = - Default (** The default action *) - | Done of 't (** Do not do the default action. Use this result *) - | Post of ('t -> 't) (** The default action, followed by the given - * transformer *) - -type 't stmtaction = - SDefault (** The default action *) - | SDone (** Do not visit this statement or its successors *) - | SUse of 't (** Visit the instructions and successors of this statement - as usual, but use the specified state instead of the - one that was passed to doStmt *) - -(* For if statements *) -type 't guardaction = - GDefault (** The default state *) - | GUse of 't (** Use this data for the branch *) - | GUnreachable (** The branch will never be taken. *) - - -(****************************************************************** - ********** - ********** FORWARDS - ********** - ********************************************************************) - -module type ForwardsTransfer = sig - val name: string (** For debugging purposes, the name of the analysis *) - - val debug: bool ref (** Whether to turn on debugging *) - - type t (** The type of the data we compute for each block start. May be - * imperative. *) - - val copy: t -> t - (** Make a deep copy of the data *) - - - val stmtStartData: t Inthash.t - (** For each statement id, the data at the start. Not found in the hash - * table means nothing is known about the state at this point. At the end - * of the analysis this means that the block is not reachable. *) - - val pretty: unit -> t -> Pretty.doc - (** Pretty-print the state *) - - val computeFirstPredecessor: Cil.stmt -> t -> t - (** Give the first value for a predecessors, compute the value to be set - * for the block *) - - val combinePredecessors: Cil.stmt -> old:t -> t -> t option - (** Take some old data for the start of a statement, and some new data for - * the same point. Return None if the combination is identical to the old - * data. Otherwise, compute the combination, and return it. *) - - val doInstr: Cil.instr -> t -> t action - (** The (forwards) transfer function for an instruction. The - * {!Cil.currentLoc} is set before calling this. The default action is to - * continue with the state unchanged. *) - - val doStmt: Cil.stmt -> t -> t stmtaction - (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} - * is set before calling this. The default action is to do the instructions - * in this statement, if applicable, and continue with the successors. *) - - val doGuard: Cil.exp -> t -> t guardaction - (** Generate the successor to an If statement assuming the given expression - * is nonzero. Analyses that don't need guard information can return - * GDefault; this is equivalent to returning GUse of the input. - * A return value of GUnreachable indicates that this half of the branch - * will not be taken and should not be explored. This will be called - * twice per If, once for "then" and once for "else". - *) - - val filterStmt: Cil.stmt -> bool - (** Whether to put this statement in the worklist. This is called when a - * block would normally be put in the worklist. *) - -end - -module ForwardsDataFlow (T : ForwardsTransfer) : sig - val compute: Cil.stmt list -> unit - (** Fill in the T.stmtStartData, given a number of initial statements to - * start from. All of the initial statements must have some entry in - * T.stmtStartData (i.e., the initial data should not be bottom) *) -end - -(****************************************************************** - ********** - ********** BACKWARDS - ********** - ********************************************************************) -module type BackwardsTransfer = sig - val name: string (** For debugging purposes, the name of the analysis *) - - val debug: bool ref (** Whether to turn on debugging *) - - type t (** The type of the data we compute for each block start. In many - * presentations of backwards data flow analysis we maintain the - * data at the block end. This is not easy to do with JVML because - * a block has many exceptional ends. So we maintain the data for - * the statement start. *) - - val pretty: unit -> t -> Pretty.doc (** Pretty-print the state *) - - val stmtStartData: t Inthash.t - (** For each block id, the data at the start. This data structure must be - * initialized with the initial data for each block *) - - val combineStmtStartData: Cil.stmt -> old:t -> t -> t option - (** When the analysis reaches the start of a block, combine the old data - * with the one we have just computed. Return None if the combination is - * the same as the old data, otherwise return the combination. In the - * latter case, the predecessors of the statement are put on the working - * list. *) - - - val combineSuccessors: t -> t -> t - (** Take the data from two successors and combine it *) - - - val doStmt: Cil.stmt -> t action - (** The (backwards) transfer function for a branch. The {!Cil.currentLoc} is - * set before calling this. If it returns None, then we have some default - * handling. Otherwise, the returned data is the data before the branch - * (not considering the exception handlers) *) - - val doInstr: Cil.instr -> t -> t action - (** The (backwards) transfer function for an instruction. The - * {!Cil.currentLoc} is set before calling this. If it returns None, then we - * have some default handling. Otherwise, the returned data is the data - * before the branch (not considering the exception handlers) *) - - val filterStmt: Cil.stmt -> Cil.stmt -> bool - (** Whether to put this predecessor block in the worklist. We give the - * predecessor and the block whose predecessor we are (and whose data has - * changed) *) - -end - -module BackwardsDataFlow (T : BackwardsTransfer) : sig - val compute: Cil.stmt list -> unit - (** Fill in the T.stmtStartData, given a number of initial statements to - * start from (the sinks for the backwards data flow). All of the statements - * (not just the initial ones!) must have some entry in T.stmtStartData - * (i.e., the initial data should not be bottom) *) -end diff --git a/cil/src/ext/dataslicing.ml b/cil/src/ext/dataslicing.ml deleted file mode 100644 index 35390b4..0000000 --- a/cil/src/ext/dataslicing.ml +++ /dev/null @@ -1,462 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2004, - * Jeremy Condit - * George C. Necula - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -open Cil -open Pretty -module E = Errormsg - -let debug = false - -let numRegions : int = 2 - -let newGlobals : global list ref = ref [] - -let curFundec : fundec ref = ref dummyFunDec -let curLocation : location ref = ref locUnknown - -let applyOption (fn : 'a -> 'b) (ao : 'a option) : 'b option = - match ao with - | Some a -> Some (fn a) - | None -> None - -let getRegion (attrs : attributes) : int = - try - match List.hd (filterAttributes "region" attrs) with - | Attr (_, [AInt i]) -> i - | _ -> E.s (bug "bad region attribute") - with Failure _ -> - 1 - -let checkRegion (i : int) (attrs : attributes) : bool = - (getRegion attrs) = i - -let regionField (i : int) : string = - "r" ^ (string_of_int i) - -let regionStruct (i : int) (name : string) : string = - name ^ "_r" ^ (string_of_int i) - -let foldRegions (fn : int -> 'a -> 'a) (base : 'a) : 'a = - let rec helper (i : int) : 'a = - if i <= numRegions then - fn i (helper (i + 1)) - else - base - in - helper 1 - -let rec getTypeName (t : typ) : string = - match t with - | TVoid _ -> "void" - | TInt _ -> "int" - | TFloat _ -> "float" - | TComp (cinfo, _) -> "comp_" ^ cinfo.cname - | TNamed (tinfo, _) -> "td_" ^ tinfo.tname - | TPtr (bt, _) -> "ptr_" ^ (getTypeName bt) - | TArray (bt, _, _) -> "array_" ^ (getTypeName bt) - | TFun _ -> "fn" - | _ -> E.s (unimp "typename") - -let isAllocFunction (fn : exp) : bool = - match fn with - | Lval (Var vinfo, NoOffset) when vinfo.vname = "malloc" -> true - | _ -> false - -let isExternalFunction (fn : exp) : bool = - match fn with - | Lval (Var vinfo, NoOffset) when vinfo.vstorage = Extern -> true - | _ -> false - -let types : (int * typsig, typ) Hashtbl.t = Hashtbl.create 113 -let typeInfos : (int * string, typeinfo) Hashtbl.t = Hashtbl.create 113 -let compInfos : (int * int, compinfo) Hashtbl.t = Hashtbl.create 113 -let varTypes : (typsig, typ) Hashtbl.t = Hashtbl.create 113 -let varCompInfos : (typsig, compinfo) Hashtbl.t = Hashtbl.create 113 - -let rec sliceCompInfo (i : int) (cinfo : compinfo) : compinfo = - try - Hashtbl.find compInfos (i, cinfo.ckey) - with Not_found -> - mkCompInfo cinfo.cstruct (regionStruct i cinfo.cname) - (fun cinfo' -> - Hashtbl.add compInfos (i, cinfo.ckey) cinfo'; - List.fold_right - (fun finfo rest -> - let t = sliceType i finfo.ftype in - if not (isVoidType t) then - (finfo.fname, t, finfo.fbitfield, - finfo.fattr, finfo.floc) :: rest - else - rest) - cinfo.cfields []) - cinfo.cattr - -and sliceTypeInfo (i : int) (tinfo : typeinfo) : typeinfo = - try - Hashtbl.find typeInfos (i, tinfo.tname) - with Not_found -> - let result = - { tinfo with tname = regionStruct i tinfo.tname; - ttype = sliceType i tinfo.ttype; } - in - Hashtbl.add typeInfos (i, tinfo.tname) result; - result - -and sliceType (i : int) (t : typ) : typ = - let ts = typeSig t in - try - Hashtbl.find types (i, ts) - with Not_found -> - let result = - match t with - | TVoid _ -> t - | TInt (_, attrs) -> if checkRegion i attrs then t else TVoid [] - | TFloat (_, attrs) -> if checkRegion i attrs then t else TVoid [] - | TComp (cinfo, attrs) -> TComp (sliceCompInfo i cinfo, attrs) - | TNamed (tinfo, attrs) -> TNamed (sliceTypeInfo i tinfo, attrs) - | TPtr (TVoid _, _) -> t (* Avoid discarding void*. *) - | TPtr (bt, attrs) -> - let bt' = sliceType i bt in - if not (isVoidType bt') then TPtr (bt', attrs) else TVoid [] - | TArray (bt, eo, attrs) -> - TArray (sliceType i bt, applyOption (sliceExp 1) eo, attrs) - | TFun (ret, args, va, attrs) -> - if checkRegion i attrs then - TFun (sliceTypeAll ret, - applyOption - (List.map (fun (aname, atype, aattrs) -> - (aname, sliceTypeAll atype, aattrs))) - args, - va, attrs) - else - TVoid [] - | TBuiltin_va_list _ -> t - | _ -> E.s (unimp "type %a" d_type t) - in - Hashtbl.add types (i, ts) result; - result - -and sliceTypeAll (t : typ) : typ = - begin - match t with - | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr -> - E.s (bug "tried to slice twice") - | _ -> () - end; - let ts = typeSig t in - try - Hashtbl.find varTypes ts - with Not_found -> - let cinfo = - let name = ("var_" ^ (getTypeName t)) in - if debug then ignore (E.log "creating %s\n" name); - try - Hashtbl.find varCompInfos ts - with Not_found -> - mkCompInfo true name - (fun cinfo -> - Hashtbl.add varCompInfos ts cinfo; - foldRegions - (fun i rest -> - let t' = sliceType i t in - if not (isVoidType t') then - (regionField i, t', None, [], !curLocation) :: rest - else - rest) - []) - [Attr ("var_type_sliced", [])] - in - let t' = - if List.length cinfo.cfields > 1 then - begin - newGlobals := GCompTag (cinfo, !curLocation) :: !newGlobals; - TComp (cinfo, []) - end - else - t - in - Hashtbl.add varTypes ts t'; - t' - -and sliceLval (i : int) (lv : lval) : lval = - if debug then ignore (E.log "lval %a\n" d_lval lv); - let lh, offset = lv in - match lh with - | Var vinfo -> - let t = sliceTypeAll vinfo.vtype in - let offset' = - match t with - | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr -> - Field (getCompField cinfo (regionField i), offset) - | _ -> offset - in - Var vinfo, offset' - | Mem e -> - Mem (sliceExp i e), offset - -and sliceExp (i : int) (e : exp) : exp = - if debug then ignore (E.log "exp %a\n" d_exp e); - match e with - | Const c -> Const c - | Lval lv -> Lval (sliceLval i lv) - | UnOp (op, e1, t) -> UnOp (op, sliceExp i e1, sliceType i t) - | BinOp (op, e1, e2, t) -> BinOp (op, sliceExp i e1, sliceExp i e2, - sliceType i t) - | CastE (t, e) -> sliceCast i t e - | AddrOf lv -> AddrOf (sliceLval i lv) - | StartOf lv -> StartOf (sliceLval i lv) - | SizeOf t -> SizeOf (sliceTypeAll t) - | _ -> E.s (unimp "exp %a" d_exp e) - -and sliceCast (i : int) (t : typ) (e : exp) : exp = - let te = typeOf e in - match t, te with - | TInt (k1, _), TInt (k2, attrs2) when k1 = k2 -> - (* Note: We strip off integer cast operations. *) - sliceExp (getRegion attrs2) e - | TInt (k1, _), TPtr _ -> - (* Note: We strip off integer cast operations. *) - sliceExp i e - | TPtr _, _ when isZero e -> - CastE (sliceType i t, sliceExp i e) - | TPtr (bt1, _), TPtr (bt2, _) when (typeSig bt1) = (typeSig bt2) -> - CastE (sliceType i t, sliceExp i e) - | _ -> - E.s (unimp "sketchy cast (%a) -> (%a)\n" d_type te d_type t) - -and sliceExpAll (e : exp) (l : location) : instr list * exp = - let t = typeOf e in - let t' = sliceTypeAll t in - match t' with - | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr -> - let vinfo = makeTempVar !curFundec t in - let instrs = - foldRegions - (fun i rest -> - try - let finfo = getCompField cinfo (regionField i) in - if not (isVoidType finfo.ftype) then - Set ((Var vinfo, Field (finfo, NoOffset)), - sliceExp i e, l) :: rest - else - rest - with Not_found -> - rest) - [] - in - instrs, Lval (var vinfo) - | _ -> [], sliceExp 1 e - -let sliceVar (vinfo : varinfo) : unit = - if hasAttribute "var_sliced" vinfo.vattr then - E.s (bug "tried to slice a var twice"); - let t = sliceTypeAll vinfo.vtype in - if debug then ignore (E.log "setting %s type to %a\n" vinfo.vname d_type t); - vinfo.vattr <- addAttribute (Attr ("var_sliced", [])) vinfo.vattr; - vinfo.vtype <- t - -let sliceInstr (inst : instr) : instr list = - match inst with - | Set (lv, e, loc) -> - if debug then ignore (E.log "set %a %a\n" d_lval lv d_exp e); - let t = typeOfLval lv in - foldRegions - (fun i rest -> - if not (isVoidType (sliceType i t)) then - Set (sliceLval i lv, sliceExp i e, loc) :: rest - else - rest) - [] - | Call (ret, fn, args, l) when isAllocFunction fn -> - let lv = - match ret with - | Some lv -> lv - | None -> E.s (bug "malloc call has no return lval") - in - let t = typeOfLval lv in - foldRegions - (fun i rest -> - if not (isVoidType (sliceType i t)) then - Call (Some (sliceLval i lv), sliceExp 1 fn, - List.map (sliceExp i) args, l) :: rest - else - rest) - [] - | Call (ret, fn, args, l) when isExternalFunction fn -> - [Call (applyOption (sliceLval 1) ret, sliceExp 1 fn, - List.map (sliceExp 1) args, l)] - | Call (ret, fn, args, l) -> - let ret', set = - match ret with - | Some lv -> - let vinfo = makeTempVar !curFundec (typeOfLval lv) in - Some (var vinfo), [Set (lv, Lval (var vinfo), l)] - | None -> - None, [] - in - let instrs, args' = - List.fold_right - (fun arg (restInstrs, restArgs) -> - let instrs, arg' = sliceExpAll arg l in - instrs @ restInstrs, (arg' :: restArgs)) - args ([], []) - in - instrs @ (Call (ret', sliceExp 1 fn, args', l) :: set) - | _ -> E.s (unimp "inst %a" d_instr inst) - -let sliceReturnExp (eo : exp option) (l : location) : stmtkind = - match eo with - | Some e -> - begin - match sliceExpAll e l with - | [], e' -> Return (Some e', l) - | instrs, e' -> Block (mkBlock [mkStmt (Instr instrs); - mkStmt (Return (Some e', l))]) - end - | None -> Return (None, l) - -let rec sliceStmtKind (sk : stmtkind) : stmtkind = - match sk with - | Instr instrs -> Instr (List.flatten (List.map sliceInstr instrs)) - | Block b -> Block (sliceBlock b) - | If (e, b1, b2, l) -> If (sliceExp 1 e, sliceBlock b1, sliceBlock b2, l) - | Break l -> Break l - | Continue l -> Continue l - | Return (eo, l) -> sliceReturnExp eo l - | Switch (e, b, sl, l) -> Switch (sliceExp 1 e, sliceBlock b, - List.map sliceStmt sl, l) -(* - | Loop (b, l, so1, so2) -> Loop (sliceBlock b, l, - applyOption sliceStmt so1, - applyOption sliceStmt so2) -*) - | While (e, b, l) -> While (sliceExp 1 e, sliceBlock b, l) - | DoWhile (e, b, l) -> DoWhile (sliceExp 1 e, sliceBlock b, l) - | For (bInit, e, bIter, b, l) -> - For (sliceBlock bInit, sliceExp 1e, sliceBlock bIter, sliceBlock b, l) - | Goto _ -> sk - | _ -> E.s (unimp "statement") - -and sliceStmt (s : stmt) : stmt = - (* Note: We update statements destructively so that goto/switch work. *) - s.skind <- sliceStmtKind s.skind; - s - -and sliceBlock (b : block) : block = - ignore (List.map sliceStmt b.bstmts); - b - -let sliceFundec (fd : fundec) (l : location) : unit = - curFundec := fd; - curLocation := l; - ignore (sliceBlock fd.sbody); - curFundec := dummyFunDec; - curLocation := locUnknown - -let sliceGlobal (g : global) : unit = - match g with - | GType (tinfo, l) -> - newGlobals := - foldRegions (fun i rest -> GType (sliceTypeInfo i tinfo, l) :: rest) - !newGlobals - | GCompTag (cinfo, l) -> - newGlobals := - foldRegions (fun i rest -> GCompTag (sliceCompInfo i cinfo, l) :: rest) - !newGlobals - | GCompTagDecl (cinfo, l) -> - newGlobals := - foldRegions (fun i rest -> GCompTagDecl (sliceCompInfo i cinfo, l) :: - rest) - !newGlobals - | GFun (fd, l) -> - sliceFundec fd l; - newGlobals := GFun (fd, l) :: !newGlobals - | GVarDecl _ - | GVar _ -> - (* Defer processing of vars until end. *) - newGlobals := g :: !newGlobals - | _ -> - E.s (unimp "global %a\n" d_global g) - -let sliceGlobalVars (g : global) : unit = - match g with - | GFun (fd, l) -> - curFundec := fd; - curLocation := l; - List.iter sliceVar fd.slocals; - List.iter sliceVar fd.sformals; - setFunctionType fd (sliceType 1 fd.svar.vtype); - curFundec := dummyFunDec; - curLocation := locUnknown; - | GVar (vinfo, _, l) -> - curLocation := l; - sliceVar vinfo; - curLocation := locUnknown - | _ -> () - -class dropAttrsVisitor = object - inherit nopCilVisitor - - method vvrbl (vinfo : varinfo) = - vinfo.vattr <- dropAttribute "var_sliced" vinfo.vattr; - DoChildren - - method vglob (g : global) = - begin - match g with - | GCompTag (cinfo, _) -> - cinfo.cattr <- dropAttribute "var_type_sliced" cinfo.cattr; - | _ -> () - end; - DoChildren -end - -let sliceFile (f : file) : unit = - newGlobals := []; - List.iter sliceGlobal f.globals; - List.iter sliceGlobalVars f.globals; - f.globals <- List.rev !newGlobals; - visitCilFile (new dropAttrsVisitor) f - -let feature : featureDescr = - { fd_name = "DataSlicing"; - fd_enabled = ref false; - fd_description = "data slicing"; - fd_extraopt = []; - fd_doit = sliceFile; - fd_post_check = true; - } diff --git a/cil/src/ext/dataslicing.mli b/cil/src/ext/dataslicing.mli deleted file mode 100644 index 0060648..0000000 --- a/cil/src/ext/dataslicing.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * Jeremy Condit - * George C. Necula - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* This feature implements data slicing. The user annotates base types - * and function types with region(i) annotations, and this transformation - * will separate the fields into parallel data structures accordingly. *) - -val feature: Cil.featureDescr diff --git a/cil/src/ext/deadcodeelim.ml b/cil/src/ext/deadcodeelim.ml deleted file mode 100644 index e560e01..0000000 --- a/cil/src/ext/deadcodeelim.ml +++ /dev/null @@ -1,173 +0,0 @@ -(* Eliminate assignment instructions whose results are not - used *) - -open Cil -open Pretty - -module E = Errormsg -module RD = Reachingdefs -module UD = Usedef -module IH = Inthash -module S = Stats - -module IS = Set.Make( - struct - type t = int - let compare = compare - end) - -let debug = RD.debug - - -let usedDefsSet = ref IS.empty -(* put used def ids into usedDefsSet *) -(* assumes reaching definitions have already been computed *) -class usedDefsCollectorClass = object(self) - inherit RD.rdVisitorClass - - method add_defids iosh e u = - UD.VS.iter (fun vi -> - if IH.mem iosh vi.vid then - let ios = IH.find iosh vi.vid in - if !debug then ignore(E.log "DCE: IOS size for vname=%s at stmt=%d: %d\n" - vi.vname sid (RD.IOS.cardinal ios)); - RD.IOS.iter (function - Some(i) -> - if !debug then ignore(E.log "DCE: def %d used: %a\n" i d_plainexp e); - usedDefsSet := IS.add i (!usedDefsSet) - | None -> ()) ios - else if !debug then ignore(E.log "DCE: vid %d:%s not in stm:%d iosh at %a\n" - vi.vid vi.vname sid d_plainexp e)) u - - method vexpr e = - let u = UD.computeUseExp e in - match self#get_cur_iosh() with - Some(iosh) -> self#add_defids iosh e u; DoChildren - | None -> - if !debug then ignore(E.log "DCE: use but no rd data: %a\n" d_plainexp e); - DoChildren - - method vinst i = - let handle_inst iosh i = match i with - | Asm(_,_,slvl,_,_,_) -> List.iter (fun (s,lv) -> - match lv with (Var v, off) -> - if s.[0] = '+' then - self#add_defids iosh (Lval(Var v, off)) (UD.VS.singleton v) - | _ -> ()) slvl - | _ -> () - in - begin try - cur_rd_dat <- Some(List.hd rd_dat_lst); - rd_dat_lst <- List.tl rd_dat_lst - with Failure "hd" -> () - end; - match self#get_cur_iosh() with - Some iosh -> handle_inst iosh i; DoChildren - | None -> DoChildren - -end - -(*************************************************** - * Also need to find reads from volatiles - * uses two functions I've put in ciltools which - * are basically what Zach wrote, except one is for - * types and one is for vars. Another difference is - * they filter out pointers to volatiles. This - * handles DMA - ***************************************************) -class hasVolatile flag = object (self) - inherit nopCilVisitor - method vlval l = - let tp = typeOfLval l in - if (Ciltools.is_volatile_tp tp) then flag := true; - DoChildren - method vexpr e = - DoChildren -end - -let exp_has_volatile e = - let flag = ref false in - ignore (visitCilExpr (new hasVolatile flag) e); - !flag - (***************************************************) - -let removedCount = ref 0 -(* Filter out instructions whose definition ids are not - in usedDefsSet *) -class uselessInstrElim : cilVisitor = object(self) - inherit nopCilVisitor - - method vstmt stm = - - let test (i,(_,s,iosh)) = - match i with - Call _ -> true - | Set((Var vi,NoOffset),e,_) -> - if vi.vglob || (Ciltools.is_volatile_vi vi) || (exp_has_volatile e) then true else - let _, defd = UD.computeUseDefInstr i in - let rec loop n = - if n < 0 then false else - if IS.mem (n+s) (!usedDefsSet) - then true - else loop (n-1) - in - if loop (UD.VS.cardinal defd - 1) - then true - else (incr removedCount; false) - | _ -> true - in - - let filter il stmdat = - let rd_dat_lst = RD.instrRDs il stm.sid stmdat false in - let ildatlst = List.combine il rd_dat_lst in - let ildatlst' = List.filter test ildatlst in - let (newil,_) = List.split ildatlst' in - newil - in - - match RD.getRDs stm.sid with - None -> DoChildren - | Some(_,s,iosh) -> - match stm.skind with - Instr il -> - stm.skind <- Instr(filter il ((),s,iosh)); - SkipChildren - | _ -> DoChildren - -end - -(* until fixed point is reached *) -let elim_dead_code_fp (fd : fundec) : fundec = - (* fundec -> fundec *) - let rec loop fd = - usedDefsSet := IS.empty; - removedCount := 0; - S.time "reaching definitions" RD.computeRDs fd; - ignore(visitCilFunction (new usedDefsCollectorClass :> cilVisitor) fd); - let fd' = visitCilFunction (new uselessInstrElim) fd in - if !removedCount = 0 then fd' else loop fd' - in - loop fd - -(* just once *) -let elim_dead_code (fd : fundec) : fundec = - (* fundec -> fundec *) - usedDefsSet := IS.empty; - removedCount := 0; - S.time "reaching definitions" RD.computeRDs fd; - ignore(visitCilFunction (new usedDefsCollectorClass :> cilVisitor) fd); - let fd' = visitCilFunction (new uselessInstrElim) fd in - fd' - -class deadCodeElimClass : cilVisitor = object(self) - inherit nopCilVisitor - - method vfunc fd = - let fd' = elim_dead_code fd in - ChangeTo(fd') - -end - -let dce f = - if !debug then ignore(E.log "DCE: starting dead code elimination\n"); - visitCilFile (new deadCodeElimClass) f diff --git a/cil/src/ext/dominators.ml b/cil/src/ext/dominators.ml deleted file mode 100755 index d838d23..0000000 --- a/cil/src/ext/dominators.ml +++ /dev/null @@ -1,241 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** Compute dominator information for the statements in a function *) -open Cil -open Pretty -module E = Errormsg -module H = Hashtbl -module U = Util -module IH = Inthash - -module DF = Dataflow - -let debug = false - -(* For each statement we maintain a set of statements that dominate it *) -module BS = Set.Make(struct - type t = Cil.stmt - let compare v1 v2 = Pervasives.compare v1.sid v2.sid - end) - - - - -(** Customization module for dominators *) -module DT = struct - let name = "dom" - - let debug = ref debug - - type t = BS.t - - (** For each statement in a function we keep the set of dominator blocks. - * Indexed by statement id *) - let stmtStartData: t IH.t = IH.create 17 - - let copy (d: t) = d - - let pretty () (d: t) = - dprintf "{%a}" - (docList (fun s -> dprintf "%d" s.sid)) - (BS.elements d) - - let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t = - (* Make sure we add this block to the set *) - BS.add s d - - let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option = - (* First, add this block to the data from the predecessor *) - let d' = BS.add s d in - if BS.subset old d' then - None - else - Some (BS.inter old d') - - let doInstr (i: instr) (d: t) = DF.Default - - let doStmt (s: stmt) (d: t) = DF.SDefault - - let doGuard condition _ = DF.GDefault - - - let filterStmt _ = true -end - - - -module Dom = DF.ForwardsDataFlow(DT) - -let getStmtDominators (data: BS.t IH.t) (s: stmt) : BS.t = - try IH.find data s.sid - with Not_found -> BS.empty (* Not reachable *) - - -let getIdom (idomInfo: stmt option IH.t) (s: stmt) = - try IH.find idomInfo s.sid - with Not_found -> - E.s (E.bug "Immediate dominator information not set for statement %d" - s.sid) - -(** Check whether one block dominates another. This assumes that the "idom" - * field has been computed. *) -let rec dominates (idomInfo: stmt option IH.t) (s1: stmt) (s2: stmt) = - s1 == s2 || - (let s2idom = getIdom idomInfo s2 in - match s2idom with - None -> false - | Some s2idom -> dominates idomInfo s1 s2idom) - - - - -let computeIDom (f: fundec) : stmt option IH.t = - (* We must prepare the CFG info first *) - prepareCFG f; - computeCFGInfo f false; - - IH.clear DT.stmtStartData; - let idomData: stmt option IH.t = IH.create 13 in - - let _ = - match f.sbody.bstmts with - [] -> () (* function has no body *) - | start :: _ -> begin - (* We start with only the start block *) - IH.add DT.stmtStartData start.sid (BS.singleton start); - - Dom.compute [start]; - - (* Dump the dominators information *) - if debug then - List.iter - (fun s -> - let sdoms = getStmtDominators DT.stmtStartData s in - if not (BS.mem s sdoms) then begin - (* It can be that the block is not reachable *) - if s.preds <> [] then - E.s (E.bug "Statement %d is not in its list of dominators" - s.sid); - end; - ignore (E.log "Dominators for %d: %a\n" s.sid - DT.pretty (BS.remove s sdoms))) - f.sallstmts; - - (* Now fill the immediate dominators for all nodes *) - let rec fillOneIdom (s: stmt) = - try - ignore (IH.find idomData s.sid) - (* Already set *) - with Not_found -> begin - (* Get the dominators *) - let sdoms = getStmtDominators DT.stmtStartData s in - (* Fill the idom for the dominators first *) - let idom = - BS.fold - (fun d (sofar: stmt option) -> - if d.sid = s.sid then - sofar (* Ignore the block itself *) - else begin - (* fill the idom information recursively *) - fillOneIdom d; - match sofar with - None -> Some d - | Some sofar' -> - (* See if d is dominated by sofar. We know that the - * idom information has been computed for both sofar - * and for d*) - if dominates idomData sofar' d then - Some d - else - sofar - end) - sdoms - None - in - IH.replace idomData s.sid idom - end - in - (* Scan all blocks and compute the idom *) - List.iter fillOneIdom f.sallstmts - end - in - idomData - - - -(** Compute the start of the natural loops. For each start, keep a list of - * origin of a back edge. The loop consists of the loop start and all - * predecessors of the origins of back edges, up to and including the loop - * start *) -let findNaturalLoops (f: fundec) - (idomData: stmt option IH.t) : (stmt * stmt list) list = - let loops = - List.fold_left - (fun acc b -> - (* Iterate over all successors, and see if they are among the - * dominators for this block *) - List.fold_left - (fun acc s -> - if dominates idomData s b then - (* s is the start of a natural loop *) - let rec addNaturalLoop = function - [] -> [(s, [b])] - | (s', backs) :: rest when s'.sid = s.sid -> - (s', b :: backs) :: rest - | l :: rest -> l :: addNaturalLoop rest - in - addNaturalLoop acc - else - acc) - acc - b.succs) - [] - f.sallstmts - in - - if debug then - ignore (E.log "Natural loops:\n%a\n" - (docList ~sep:line - (fun (s, backs) -> - dprintf " Start: %d, backs:%a" - s.sid - (docList (fun b -> num b.sid)) - backs)) - loops); - - loops diff --git a/cil/src/ext/dominators.mli b/cil/src/ext/dominators.mli deleted file mode 100755 index 0abf82e..0000000 --- a/cil/src/ext/dominators.mli +++ /dev/null @@ -1,29 +0,0 @@ - - -(** Compute dominators using data flow analysis *) -(** Author: George Necula - 5/28/2004 - **) - -(** Invoke on a code after filling in the CFG info and it computes the - * immediate dominator information. We map each statement to its immediate - * dominator (None for the start statement, and for the unreachable - * statements). *) -val computeIDom: Cil.fundec -> Cil.stmt option Inthash.t - - -(** This is like Inthash.find but gives an error if the information is - * Not_found *) -val getIdom: Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option - -(** Check whether one statement dominates another. *) -val dominates: Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool - - -(** Compute the start of the natural loops. This assumes that the "idom" - * field has been computed. For each start, keep a list of origin of a back - * edge. The loop consists of the loop start and all predecessors of the - * origins of back edges, up to and including the loop start *) -val findNaturalLoops: Cil.fundec -> - Cil.stmt option Inthash.t -> - (Cil.stmt * Cil.stmt list) list diff --git a/cil/src/ext/epicenter.ml b/cil/src/ext/epicenter.ml deleted file mode 100644 index a8045e8..0000000 --- a/cil/src/ext/epicenter.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* epicenter.ml *) -(* code for epicenter.mli *) - -(* module maintainer: scott *) -(* see copyright at end of this file *) - -open Callgraph -open Cil -open Trace -open Pretty -module H = Hashtbl -module IH = Inthash - -let sliceFile (f:file) (epicenter:string) (maxHops:int) : unit = - (* compute the static call graph *) - let graph:callgraph = (computeGraph f) in - - (* will accumulate here the set of names of functions already seen *) - let seen: (string, unit) H.t = (H.create 117) in - - (* when removing "unused" symbols, keep all seen functions *) - let isRoot : global -> bool = function - | GFun ({svar = {vname = vname}}, _) -> - H.mem seen vname - | _ -> - false - in - - (* recursive depth-first search through the call graph, finding - * all nodes within 'hops' hops of 'node' and marking them to - * to be retained *) - let rec dfs (node:callnode) (hops:int) : unit = - (* only recurse if we haven't already marked this node *) - if not (H.mem seen (nodeName node.cnInfo)) then - begin - (* add this node *) - H.add seen (nodeName node.cnInfo) (); - trace "epicenter" (dprintf "will keep %s\n" (nodeName node.cnInfo)); - - (* if we cannot do any more hops, stop *) - if (hops > 0) then - - (* recurse on all the node's callers and callees *) - let recurse _ (adjacent:callnode) : unit = - (dfs adjacent (hops - 1)) - in - IH.iter recurse node.cnCallees; - IH.iter recurse node.cnCallers - end - in - dfs (Hashtbl.find graph epicenter) maxHops; - - (* finally, throw away anything we haven't decided to keep *) - Cilutil.sliceGlobal := true; - Rmtmps.removeUnusedTemps ~isRoot:isRoot f - -let doEpicenter = ref false -let epicenterName = ref "" -let epicenterHops = ref 0 - -let feature : featureDescr = - { fd_name = "epicenter"; - fd_enabled = doEpicenter; - fd_description = "remove all functions except those within some number " ^ - "of hops (in the call graph) from a given function"; - fd_extraopt = - [ - ("--epicenter-name", - Arg.String (fun s -> epicenterName := s), - ": do an epicenter slice starting from function "); - ("--epicenter-hops", Arg.Int (fun n -> epicenterHops := n), - ": specify max # of hops for epicenter slice"); - ]; - - fd_doit = - (fun f -> - sliceFile f !epicenterName !epicenterHops); - - fd_post_check = true; - } - - -(* - * - * Copyright (c) 2001-2002 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * Ben Liblit liblit@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) diff --git a/cil/src/ext/heap.ml b/cil/src/ext/heap.ml deleted file mode 100644 index 10f48a0..0000000 --- a/cil/src/ext/heap.ml +++ /dev/null @@ -1,112 +0,0 @@ -(* See copyright notice at the end of the file *) - -(* The type of a heap (priority queue): keys are integers, data values - * are whatever you like *) -type ('a) t = { - elements : (int * ('a option)) array ; - mutable size : int ; (* current number of elements *) - capacity : int ; (* max number of elements *) -} - -let create size = { - elements = Array.create (size+1) (max_int,None) ; - size = 0 ; - capacity = size ; -} - -let clear heap = heap.size <- 0 - -let is_full heap = (heap.size = heap.capacity) - -let is_empty heap = (heap.size = 0) - -let insert heap prio elt = begin - if is_full heap then begin - raise (Invalid_argument "Heap.insert") - end ; - heap.size <- heap.size + 1 ; - let i = ref heap.size in - while ( fst heap.elements.(!i / 2) < prio ) do - heap.elements.(!i) <- heap.elements.(!i / 2) ; - i := (!i / 2) - done ; - heap.elements.(!i) <- (prio,Some(elt)) - end - -let examine_max heap = - if is_empty heap then begin - raise (Invalid_argument "Heap.examine_max") - end ; - match heap.elements.(1) with - p,Some(elt) -> p,elt - | p,None -> failwith "Heap.examine_max" - -let extract_max heap = begin - if is_empty heap then begin - raise (Invalid_argument "Heap.extract_max") - end ; - let max = heap.elements.(1) in - let last = heap.elements.(heap.size) in - heap.size <- heap.size - 1 ; - let i = ref 1 in - let break = ref false in - while (!i * 2 <= heap.size) && not !break do - let child = ref (!i * 2) in - - (* find smaller child *) - if (!child <> heap.size && - fst heap.elements.(!child+1) > fst heap.elements.(!child)) then begin - incr child - end ; - - (* percolate one level *) - if (fst last < fst heap.elements.(!child)) then begin - heap.elements.(!i) <- heap.elements.(!child) ; - i := !child - end else begin - break := true - end - done ; - heap.elements.(!i) <- last ; - match max with - p,Some(elt) -> p,elt - | p,None -> failwith "Heap.examine_min" - end - - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) diff --git a/cil/src/ext/heapify.ml b/cil/src/ext/heapify.ml deleted file mode 100644 index a583181..0000000 --- a/cil/src/ext/heapify.ml +++ /dev/null @@ -1,250 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* - * Heapify: a program transform that looks over functions, finds those - * that have local (stack) variables that contain arrays, puts all such - * local variables into a single heap allocated structure, changes all - * accesses to such variables into accesses to fields of that structure - * and frees the structure on return. - *) -open Cil - -(* utilities that should be in Cil.ml *) -(* sfg: this function appears to never be called *) -let mkSimpleField ci fn ft fl = - { fcomp = ci ; fname = fn ; ftype = ft ; fbitfield = None ; fattr = []; - floc = fl } - - -(* actual Heapify begins *) - -let heapifyNonArrays = ref false - -(* Does this local var contain an array? *) -let rec containsArray (t:typ) : bool = (* does this type contain an array? *) - match unrollType t with - TArray _ -> true - | TComp(ci, _) -> (* look at the types of the fields *) - List.exists (fun fi -> containsArray fi.ftype) ci.cfields - | _ -> - (* Ignore other types, including TInt and TPtr. We don't care whether - there are arrays in the base types of pointers; only about whether - this local variable itself needs to be moved to the heap. *) - false - - -class heapifyModifyVisitor big_struct big_struct_fields varlist free - (currentFunction: fundec) = object(self) - inherit nopCilVisitor (* visit lvalues and statements *) - method vlval l = match l with (* should we change this one? *) - Var(vi),vi_offset when List.mem_assoc vi varlist -> (* check list *) - let i = List.assoc vi varlist in (* find field offset *) - let big_struct_field = List.nth big_struct_fields i in - let new_lval = Mem(Lval(big_struct, NoOffset)), - Field(big_struct_field,vi_offset) in (* rewrite the lvalue *) - ChangeDoChildrenPost(new_lval, (fun l -> l)) - | _ -> DoChildren (* ignore other lvalues *) - method vstmt s = match s.skind with (* also rewrite the return *) - Return(None,loc) -> - let free_instr = Call(None,free,[Lval(big_struct,NoOffset)],loc) in - self#queueInstr [free_instr]; (* insert free_instr before the return *) - DoChildren - | Return(Some exp ,loc) -> - (* exp may depend on big_struct, so evaluate it before calling free. - * This becomes: tmp = exp; free(big_struct); return tmp; *) - let exp_new = visitCilExpr (self :> cilVisitor) exp in - let ret_tmp = makeTempVar currentFunction (typeOf exp_new) in - let eval_ret_instr = Set(var ret_tmp, exp_new, loc) in - let free_instr = Call(None,free,[Lval(big_struct,NoOffset)],loc) in - (* insert the instructions before the return *) - self#queueInstr [eval_ret_instr; free_instr]; - s.skind <- (Return(Some(Lval(var ret_tmp)), loc)); - DoChildren - | _ -> DoChildren (* ignore other statements *) -end - -class heapifyAnalyzeVisitor f alloc free = object - inherit nopCilVisitor (* only look at function bodies *) - method vglob gl = match gl with - GFun(fundec,funloc) -> - let counter = ref 0 in (* the number of local vars containing arrays *) - let varlist = ref [] in (* a list of (var,id) pairs, in reverse order *) - List.iter (fun vi -> - (* find all local vars with arrays. If the user requests it, - we also look for non-array vars whose address is taken. *) - if (containsArray vi.vtype) || (vi.vaddrof && !heapifyNonArrays) - then begin - varlist := (vi,!counter) :: !varlist ; (* add it to the list *) - incr counter (* put the next such var in the next slot *) - end - ) fundec.slocals ; - if (!varlist <> []) then begin (* some local vars contain arrays *) - let name = (fundec.svar.vname ^ "_heapify") in - let ci = mkCompInfo true name (* make a big structure *) - (fun _ -> List.rev_map (* reverse the list to fix the order *) - (* each local var becomes a field *) - (fun (vi,i) -> vi.vname,vi.vtype,None,[],vi.vdecl) !varlist) [] in - let vi = makeLocalVar fundec name (TPtr(TComp(ci,[]),[])) in - let modify = new heapifyModifyVisitor (Var(vi)) ci.cfields - !varlist free fundec in (* rewrite accesses to local vars *) - fundec.sbody <- visitCilBlock modify fundec.sbody ; - let alloc_stmt = mkStmt (* allocate the big struct on the heap *) - (Instr [Call(Some(Var(vi),NoOffset), alloc, - [SizeOf(TComp(ci,[]))],funloc)]) in - fundec.sbody.bstmts <- alloc_stmt :: fundec.sbody.bstmts ; - fundec.slocals <- List.filter (fun vi -> (* remove local vars *) - not (List.mem_assoc vi !varlist)) fundec.slocals ; - let typedec = (GCompTag(ci,funloc)) in (* declare the big struct *) - ChangeTo([typedec ; GFun(fundec,funloc)]) (* done! *) - end else - DoChildren (* ignore everything else *) - | _ -> DoChildren -end - -let heapify (f : file) (alloc : exp) (free : exp) = - visitCilFile (new heapifyAnalyzeVisitor f alloc free) f; - f - -(* heapify code ends here *) - -let default_heapify (f : file) = - let alloc_fun = emptyFunction "malloc" in - let free_fun = emptyFunction "free" in - let alloc_exp = (Lval((Var(alloc_fun.svar)),NoOffset)) in - let free_exp = (Lval((Var(free_fun.svar)),NoOffset)) in - ignore (heapify f alloc_exp free_exp) - -(* StackGuard clone *) - -class sgModifyVisitor restore_ra_stmt = object - inherit nopCilVisitor - method vstmt s = match s.skind with (* also rewrite the return *) - Return(_,loc) -> let new_block = mkBlock [restore_ra_stmt ; s] in - ChangeTo(mkStmt (Block(new_block))) - | _ -> DoChildren (* ignore other statements *) -end - -class sgAnalyzeVisitor f push pop get_ra set_ra = object - inherit nopCilVisitor - method vfunc fundec = - let needs_guarding = List.fold_left - (fun acc vi -> acc || containsArray vi.vtype) - false fundec.slocals in - if needs_guarding then begin - let ra_tmp = makeLocalVar fundec "return_address" voidPtrType in - let ra_exp = Lval(Var(ra_tmp),NoOffset) in - let save_ra_stmt = mkStmt (* save the current return address *) - (Instr [Call(Some(Var(ra_tmp),NoOffset), get_ra, [], locUnknown) ; - Call(None, push, [ra_exp], locUnknown)]) in - let restore_ra_stmt = mkStmt (* restore the old return address *) - (Instr [Call(Some(Var(ra_tmp),NoOffset), pop, [], locUnknown) ; - Call(None, set_ra, [ra_exp], locUnknown)]) in - let modify = new sgModifyVisitor restore_ra_stmt in - fundec.sbody <- visitCilBlock modify fundec.sbody ; - fundec.sbody.bstmts <- save_ra_stmt :: fundec.sbody.bstmts ; - ChangeTo(fundec) (* done! *) - end else DoChildren -end - -let stackguard (f : file) (push : exp) (pop : exp) - (get_ra : exp) (set_ra : exp) = - visitCilFileSameGlobals (new sgAnalyzeVisitor f push pop get_ra set_ra) f; - f - (* stackguard code ends *) - -let default_stackguard (f : file) = - let expify fundec = Lval(Var(fundec.svar),NoOffset) in - let push = expify (emptyFunction "stackguard_push") in - let pop = expify (emptyFunction "stackguard_pop") in - let get_ra = expify (emptyFunction "stackguard_get_ra") in - let set_ra = expify (emptyFunction "stackguard_set_ra") in - let global_decl = -"extern void * stackguard_get_ra(); -extern void stackguard_set_ra(void *new_ra); -/* You must provide an implementation for functions that get and set the - * return address. Such code is unfortunately architecture specific. - */ -struct stackguard_stack { - void * data; - struct stackguard_stack * next; -} * stackguard_stack; - -void stackguard_push(void *ra) { - void * old = stackguard_stack; - stackguard_stack = (struct stackguard_stack *) - malloc(sizeof(stackguard_stack)); - stackguard_stack->data = ra; - stackguard_stack->next = old; -} - -void * stackguard_pop() { - void * ret = stackguard_stack->data; - void * next = stackguard_stack->next; - free(stackguard_stack); - stackguard_stack->next = next; - return ret; -}" in - f.globals <- GText(global_decl) :: f.globals ; - ignore (stackguard f push pop get_ra set_ra ) - - -let feature1 : featureDescr = - { fd_name = "stackGuard"; - fd_enabled = Cilutil.doStackGuard; - fd_description = "instrument function calls and returns to maintain a separate stack for return addresses" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> default_stackguard f); - fd_post_check = true; - } -let feature2 : featureDescr = - { fd_name = "heapify"; - fd_enabled = Cilutil.doHeapify; - fd_description = "move stack-allocated arrays to the heap" ; - fd_extraopt = [ - "--heapifyAll", Arg.Set heapifyNonArrays, - "When using heapify, move all local vars whose address is taken, not just arrays."; - ]; - fd_doit = (function (f: file) -> default_heapify f); - fd_post_check = true; - } - - - - - - diff --git a/cil/src/ext/liveness.ml b/cil/src/ext/liveness.ml deleted file mode 100644 index 72cd607..0000000 --- a/cil/src/ext/liveness.ml +++ /dev/null @@ -1,190 +0,0 @@ - -(* Calculate which variables are live at - * each statememnt. - * - * - * - *) - -open Cil -open Pretty - -module DF = Dataflow -module UD = Usedef -module IH = Inthash -module E = Errormsg - -let debug = ref false - -let live_label = ref "" -let live_func = ref "" - -module VS = UD.VS - -let debug_print () vs = (VS.fold - (fun vi d -> - d ++ text "name: " ++ text vi.vname - ++ text " id: " ++ num vi.vid ++ text " ") - vs nil) ++ line - -let min_print () vs = (VS.fold - (fun vi d -> - d ++ text vi.vname - ++ text "(" ++ d_type () vi.vtype ++ text ")" - ++ text ",") - vs nil) ++ line - -let printer = ref debug_print - -module LiveFlow = struct - let name = "Liveness" - let debug = debug - type t = VS.t - - let pretty () vs = - let fn = !printer in - fn () vs - - let stmtStartData = IH.create 32 - - let combineStmtStartData (stm:stmt) ~(old:t) (now:t) = - if not(VS.compare old now = 0) - then Some(VS.union old now) - else None - - let combineSuccessors = VS.union - - let doStmt stmt = - if !debug then ignore(E.log "looking at: %a\n" d_stmt stmt); - match stmt.succs with - [] -> let u,d = UD.computeUseDefStmtKind stmt.skind in - if !debug then ignore(E.log "doStmt: no succs %d\n" stmt.sid); - DF.Done u - | _ -> - let handle_stm vs = match stmt.skind with - Instr _ -> vs - | s -> let u, d = UD.computeUseDefStmtKind s in - VS.union u (VS.diff vs d) - in - DF.Post handle_stm - - let doInstr i vs = - let transform vs' = - let u,d = UD.computeUseDefInstr i in - VS.union u (VS.diff vs' d) - in - DF.Post transform - - let filterStmt stm1 stm2 = true - -end - -module L = DF.BackwardsDataFlow(LiveFlow) - -let sink_stmts = ref [] -class sinkFinderClass = object(self) - inherit nopCilVisitor - - method vstmt s = match s.succs with - [] -> (sink_stmts := s :: (!sink_stmts); - DoChildren) - | _ -> DoChildren - -end - -(* gives list of return statements from a function *) -(* fundec -> stm list *) -let find_sinks fdec = - sink_stmts := []; - ignore(visitCilFunction (new sinkFinderClass) fdec); - !sink_stmts - -(* XXX: This does not compute the best ordering to - * give to the work-list algorithm. - *) -let all_stmts = ref [] -class nullAdderClass = object(self) - inherit nopCilVisitor - - method vstmt s = - all_stmts := s :: (!all_stmts); - IH.add LiveFlow.stmtStartData s.sid VS.empty; - DoChildren - -end - -let null_adder fdec = - ignore(visitCilFunction (new nullAdderClass) fdec); - !all_stmts - -let computeLiveness fdec = - IH.clear LiveFlow.stmtStartData; - UD.onlyNoOffsetsAreDefs := false; - all_stmts := []; - let a = null_adder fdec in - L.compute a - -let print_everything () = - let d = IH.fold (fun i vs d -> - d ++ num i ++ text ": " ++ LiveFlow.pretty () vs) - LiveFlow.stmtStartData nil in - ignore(printf "%t" (fun () -> d)) - -let match_label lbl = match lbl with - Label(str,_,b) -> - if !debug then ignore(E.log "Liveness: label seen: %s\n" str); - (*b && *)(String.compare str (!live_label) = 0) -| _ -> false - -class doFeatureClass = object(self) - inherit nopCilVisitor - - method vfunc fd = - if String.compare fd.svar.vname (!live_func) = 0 then - (Cfg.clearCFGinfo fd; - ignore(Cfg.cfgFun fd); - computeLiveness fd; - if String.compare (!live_label) "" = 0 then - (printer := min_print; - print_everything(); - SkipChildren) - else DoChildren) - else SkipChildren - - method vstmt s = - if List.exists match_label s.labels then try - let vs = IH.find LiveFlow.stmtStartData s.sid in - (printer := min_print; - ignore(printf "%a" LiveFlow.pretty vs); - SkipChildren) - with Not_found -> - if !debug then ignore(E.log "Liveness: stmt: %d not found\n" s.sid); - DoChildren - else - (if List.length s.labels = 0 then - if !debug then ignore(E.log "Liveness: no label at sid=%d\n" s.sid); - DoChildren) - -end - -let do_live_feature (f:file) = - visitCilFile (new doFeatureClass) f - -let feature = - { - fd_name = "Liveness"; - fd_enabled = ref false; - fd_description = "Spit out live variables at a label"; - fd_extraopt = [ - "--live_label", - Arg.String (fun s -> live_label := s), - "Output the variables live at this label"; - "--live_func", - Arg.String (fun s -> live_func := s), - "Output the variables live at each statement in this function."; - "--live_debug", - Arg.Unit (fun n -> debug := true), - "Print lots of debugging info";]; - fd_doit = do_live_feature; - fd_post_check = false - } diff --git a/cil/src/ext/logcalls.ml b/cil/src/ext/logcalls.ml deleted file mode 100644 index 0cdbc15..0000000 --- a/cil/src/ext/logcalls.ml +++ /dev/null @@ -1,268 +0,0 @@ -(** See copyright notice at the end of this file *) - -(** Add printf before each function call *) - -open Pretty -open Cil -open Trace -module E = Errormsg -module H = Hashtbl - -let i = ref 0 -let name = ref "" - -(* Switches *) -let printFunctionName = ref "printf" - -let addProto = ref false - -let printf: varinfo option ref = ref None -let makePrintfFunction () : varinfo = - match !printf with - Some v -> v - | None -> begin - let v = makeGlobalVar !printFunctionName - (TFun(voidType, Some [("format", charPtrType, [])], - true, [])) in - printf := Some v; - addProto := true; - v - end - -let mkPrint (format: string) (args: exp list) : instr = - let p: varinfo = makePrintfFunction () in - Call(None, Lval(var p), (mkString format) :: args, !currentLoc) - - -let d_string (fmt : ('a,unit,doc,string) format4) : 'a = - let f (d: doc) : string = - Pretty.sprint 200 d - in - Pretty.gprintf f fmt - -let currentFunc: string ref = ref "" - -class logCallsVisitorClass = object - inherit nopCilVisitor - - (* Watch for a declaration for our printer *) - - method vinst i = begin - match i with - | Call(lo,e,al,l) -> - let pre = mkPrint (d_string "call %a\n" d_exp e) [] in - let post = mkPrint (d_string "return from %a\n" d_exp e) [] in -(* - let str1 = prefix ^ - (Pretty.sprint 800 ( Pretty.dprintf "Calling %a(%a)\n" - d_exp e - (docList ~sep:(chr ',' ++ break ) (fun arg -> - try - match unrollType (typeOf arg) with - TInt _ | TEnum _ -> dprintf "%a = %%d" d_exp arg - | TFloat _ -> dprintf "%a = %%g" d_exp arg - | TVoid _ -> text "void" - | TComp _ -> text "comp" - | _ -> dprintf "%a = %%p" d_exp arg - with _ -> dprintf "%a = %%p" d_exp arg)) al)) in - let log_args = List.filter (fun arg -> - match unrollType (typeOf arg) with - TVoid _ | TComp _ -> false - | _ -> true) al in - let str2 = prefix ^ (Pretty.sprint 800 - ( Pretty.dprintf "Returned from %a\n" d_exp e)) in - let newinst str args = ((Call (None, Lval(var printfFun.svar), - ( [ (* one ; *) mkString str ] @ args), - locUnknown)) : instr )in - let ilist = ([ (newinst str1 log_args) ; i ; (newinst str2 []) ] : instr list) in - *) - ChangeTo [ pre; i; post ] - - | _ -> DoChildren - end - method vstmt (s : stmt) = begin - match s.skind with - Return _ -> - let pre = mkPrint (d_string "exit %s\n" !currentFunc) [] in - ChangeTo (mkStmt (Block (mkBlock [ mkStmtOneInstr pre; s ]))) - | _ -> DoChildren - -(* -(Some(e),l) -> - let str = prefix ^ Pretty.sprint 800 ( Pretty.dprintf - "Return(%%p) from %s\n" funstr ) in - let newinst = ((Call (None, Lval(var printfFun.svar), - ( [ (* one ; *) mkString str ; e ]), - locUnknown)) : instr )in - let new_stmt = mkStmtOneInstr newinst in - let slist = [ new_stmt ; s ] in - (ChangeTo(mkStmt(Block(mkBlock slist)))) - | Return(None,l) -> - let str = prefix ^ (Pretty.sprint 800 ( Pretty.dprintf - "Return void from %s\n" funstr)) in - let newinst = ((Call (None, Lval(var printfFun.svar), - ( [ (* one ; *) mkString str ]), - locUnknown)) : instr )in - let new_stmt = mkStmtOneInstr newinst in - let slist = [ new_stmt ; s ] in - (ChangeTo(mkStmt(Block(mkBlock slist)))) - | _ -> DoChildren -*) - end -end - -let logCallsVisitor = new logCallsVisitorClass - - -let logCalls (f: file) : unit = - - let doGlobal = function - | GVarDecl (v, _) when v.vname = !printFunctionName -> - if !printf = None then - printf := Some v - - | GFun (fdec, loc) -> - currentFunc := fdec.svar.vname; - (* do the body *) - ignore (visitCilFunction logCallsVisitor fdec); - (* Now add the entry instruction *) - let pre = mkPrint (d_string "enter %s\n" !currentFunc) [] in - fdec.sbody <- - mkBlock [ mkStmtOneInstr pre; - mkStmt (Block fdec.sbody) ] -(* - (* debugging 'anagram', it's really nice to be able to see the strings *) - (* inside fat pointers, even if it's a bit of a hassle and a hack here *) - let isFatCharPtr (cinfo:compinfo) = - cinfo.cname="wildp_char" || - cinfo.cname="fseqp_char" || - cinfo.cname="seqp_char" in - - (* Collect expressions that denote the actual arguments *) - let actargs = - (* make lvals out of args which pass test below *) - (List.map - (fun vi -> match unrollType vi.vtype with - | TComp(cinfo, _) when isFatCharPtr(cinfo) -> - (* access the _p field for these *) - (* luckily it's called "_p" in all three fat pointer variants *) - Lval(Var(vi), Field(getCompField cinfo "_p", NoOffset)) - | _ -> - Lval(var vi)) - - (* decide which args to pass *) - (List.filter - (fun vi -> match unrollType vi.vtype with - | TPtr(TInt(k, _), _) when isCharType(k) -> - !printPtrs || !printStrings - | TComp(cinfo, _) when isFatCharPtr(cinfo) -> - !printStrings - | TVoid _ | TComp _ -> false - | TPtr _ | TArray _ | TFun _ -> !printPtrs - | _ -> true) - fdec.sformals) - ) in - - (* make a format string for printing them *) - (* sm: expanded width to 200 because I want one per line *) - let formatstr = prefix ^ (Pretty.sprint 200 - (dprintf "entering %s(%a)\n" fdec.svar.vname - (docList ~sep:(chr ',' ++ break) - (fun vi -> match unrollType vi.vtype with - | TInt _ | TEnum _ -> dprintf "%s = %%d" vi.vname - | TFloat _ -> dprintf "%s = %%g" vi.vname - | TVoid _ -> dprintf "%s = (void)" vi.vname - | TComp(cinfo, _) -> ( - if !printStrings && isFatCharPtr(cinfo) then - dprintf "%s = \"%%s\"" vi.vname - else - dprintf "%s = (comp)" vi.vname - ) - | TPtr(TInt(k, _), _) when isCharType(k) -> ( - if (!printStrings) then - dprintf "%s = \"%%s\"" vi.vname - else if (!printPtrs) then - dprintf "%s = %%p" vi.vname - else - dprintf "%s = (str)" vi.vname - ) - | TPtr _ | TArray _ | TFun _ -> ( - if (!printPtrs) then - dprintf "%s = %%p" vi.vname - else - dprintf "%s = (ptr)" vi.vname - ) - | _ -> dprintf "%s = (?type?)" vi.vname)) - fdec.sformals)) in - - i := 0 ; - name := fdec.svar.vname ; - if !allInsts then ( - let thisVisitor = new verboseLogVisitor printfFun !name prefix in - fdec.sbody <- visitCilBlock thisVisitor fdec.sbody - ); - fdec.sbody.bstmts <- - mkStmt (Instr [Call (None, Lval(var printfFun.svar), - ( (* one :: *) mkString formatstr - :: actargs), - loc)]) :: fdec.sbody.bstmts - *) - | _ -> () - in - Stats.time "logCalls" (iterGlobals f) doGlobal; - if !addProto then begin - let p = makePrintfFunction () in - E.log "Adding prototype for call logging function %s\n" p.vname; - f.globals <- GVarDecl (p, locUnknown) :: f.globals - end - -let feature : featureDescr = - { fd_name = "logcalls"; - fd_enabled = Cilutil.logCalls; - fd_description = "generation of code to log function calls"; - fd_extraopt = [ - ("--logcallprintf", Arg.String (fun s -> printFunctionName := s), - "the name of the printf function to use"); - ("--logcalladdproto", Arg.Unit (fun s -> addProto := true), - "whether to add the prototype for the printf function") - ]; - fd_doit = logCalls; - fd_post_check = true - } - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) diff --git a/cil/src/ext/logcalls.mli b/cil/src/ext/logcalls.mli deleted file mode 100644 index 22a1e96..0000000 --- a/cil/src/ext/logcalls.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* A simple CIL transformer that inserts calls to a runtime function to log - * the call in each function *) -val feature: Cil.featureDescr diff --git a/cil/src/ext/logwrites.ml b/cil/src/ext/logwrites.ml deleted file mode 100644 index 3afd067..0000000 --- a/cil/src/ext/logwrites.ml +++ /dev/null @@ -1,139 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -open Pretty -open Cil -module E = Errormsg -module H = Hashtbl - -(* David Park at Stanford points out that you cannot take the address of a - * bitfield in GCC. *) - -(* Returns true if the given lvalue offset ends in a bitfield access. *) -let rec is_bitfield lo = match lo with - | NoOffset -> false - | Field(fi,NoOffset) -> not (fi.fbitfield = None) - | Field(_,lo) -> is_bitfield lo - | Index(_,lo) -> is_bitfield lo - -(* Return an expression that evaluates to the address of the given lvalue. - * For most lvalues, this is merely AddrOf(lv). However, for bitfields - * we do some offset gymnastics. - *) -let addr_of_lv (lh,lo) = - if is_bitfield lo then begin - (* we figure out what the address would be without the final bitfield - * access, and then we add in the offset of the bitfield from the - * beginning of its enclosing comp *) - let rec split_offset_and_bitfield lo = match lo with - | NoOffset -> failwith "logwrites: impossible" - | Field(fi,NoOffset) -> (NoOffset,fi) - | Field(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Field(e,a)),b) - | Index(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Index(e,a)),b) - in - let new_lv_offset, bf = split_offset_and_bitfield lo in - let new_lv = (lh, new_lv_offset) in - let enclosing_type = TComp(bf.fcomp, []) in - let bits_offset, bits_width = - bitsOffset enclosing_type (Field(bf,NoOffset)) in - let bytes_offset = bits_offset / 8 in - let lvPtr = mkCast ~e:(mkAddrOf (new_lv)) ~newt:(charPtrType) in - (BinOp(PlusPI, lvPtr, (integer bytes_offset), ulongType)) - end else (AddrOf (lh,lo)) - -class logWriteVisitor = object - inherit nopCilVisitor - (* Create a prototype for the logging function, but don't put it in the - * file *) - val printfFun = - let fdec = emptyFunction "syslog" in - fdec.svar.vtype <- TFun(intType, - Some [ ("prio", intType, []); - ("format", charConstPtrType, []) ], - true, []); - fdec - - method vinst (i: instr) : instr list visitAction = - match i with - Set(lv, e, l) -> begin - (* Check if we need to log *) - match lv with - (Var(v), off) when not v.vglob -> SkipChildren - | _ -> let str = Pretty.sprint 80 - (Pretty.dprintf "Write %%p to 0x%%08x at %%s:%%d (%a)\n" d_lval lv) - in - ChangeTo - [ Call((None), (Lval(Var(printfFun.svar),NoOffset)), - [ one ; - mkString str ; e ; addr_of_lv lv; - mkString l.file; - integer l.line], locUnknown); - i] - end - | Call(Some lv, f, args, l) -> begin - (* Check if we need to log *) - match lv with - (Var(v), off) when not v.vglob -> SkipChildren - | _ -> let str = Pretty.sprint 80 - (Pretty.dprintf "Write retval to 0x%%08x at %%s:%%d (%a)\n" d_lval lv) - in - ChangeTo - [ Call((None), (Lval(Var(printfFun.svar),NoOffset)), - [ one ; - mkString str ; AddrOf lv; - mkString l.file; - integer l.line], locUnknown); - i] - end - | _ -> SkipChildren - -end - -let feature : featureDescr = - { fd_name = "logwrites"; - fd_enabled = Cilutil.logWrites; - fd_description = "generation of code to log memory writes"; - fd_extraopt = []; - fd_doit = - (function (f: file) -> - let lwVisitor = new logWriteVisitor in - visitCilFileSameGlobals lwVisitor f); - fd_post_check = true; - } - diff --git a/cil/src/ext/oneret.ml b/cil/src/ext/oneret.ml deleted file mode 100644 index b3ce4a1..0000000 --- a/cil/src/ext/oneret.ml +++ /dev/null @@ -1,187 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Make sure that there is exactly one Return statement in the whole body. - * Replace all the other returns with Goto. This is convenient if you later - * want to insert some finalizer code, since you have a precise place where - * to put it *) -open Cil -open Pretty - -module E = Errormsg - -let dummyVisitor = new nopCilVisitor - -let oneret (f: Cil.fundec) : unit = - let fname = f.svar.vname in - (* Get the return type *) - let retTyp = - match f.svar.vtype with - TFun(rt, _, _, _) -> rt - | _ -> E.s (E.bug "Function %s does not have a function type\n" - f.svar.vname) - in - (* Does it return anything ? *) - let hasRet = match unrollType retTyp with TVoid _ -> false | _ -> true in - - (* Memoize the return result variable. Use only if hasRet *) - let lastloc = ref locUnknown in - let retVar : varinfo option ref = ref None in - let getRetVar (x: unit) : varinfo = - match !retVar with - Some rv -> rv - | None -> begin - let rv = makeLocalVar f "__retres" retTyp in (* don't collide *) - retVar := Some rv; - rv - end - in - (* Remember if we have introduced goto's *) - let haveGoto = ref false in - (* Memoize the return statement *) - let retStmt : stmt ref = ref dummyStmt in - let getRetStmt (x: unit) : stmt = - if !retStmt == dummyStmt then begin - (* Must create a statement *) - let rv = - if hasRet then Some (Lval(Var (getRetVar ()), NoOffset)) else None - in - let sr = mkStmt (Return (rv, !lastloc)) in - retStmt := sr; - sr - end else - !retStmt - in - (* Now scan all the statements. Know if you are the main body of the - * function and be prepared to add new statements at the end *) - let rec scanStmts (mainbody: bool) = function - | [] when mainbody -> (* We are at the end of the function. Now it is - * time to add the return statement *) - let rs = getRetStmt () in - if !haveGoto then - rs.labels <- (Label("return_label", !lastloc, false)) :: rs.labels; - [rs] - - | [] -> [] - - | ({skind=Return (retval, l)} as s) :: rests -> - currentLoc := l; -(* - ignore (E.log "Fixing return(%a) at %a\n" - insert - (match retval with None -> text "None" - | Some e -> d_exp () e) - d_loc l); -*) - if hasRet && retval = None then - E.s (error "Found return without value in function %s\n" fname); - if not hasRet && retval <> None then - E.s (error "Found return in subroutine %s\n" fname); - (* Keep this statement because it might have labels. But change it to - * an instruction that sets the return value (if any). *) - s.skind <- begin - match retval with - Some rval -> Instr [Set((Var (getRetVar ()), NoOffset), rval, l)] - | None -> Instr [] - end; - (* See if this is the last statement in function *) - if mainbody && rests == [] then - s :: scanStmts mainbody rests - else begin - (* Add a Goto *) - let sgref = ref (getRetStmt ()) in - let sg = mkStmt (Goto (sgref, l)) in - haveGoto := true; - s :: sg :: (scanStmts mainbody rests) - end - - | ({skind=If(eb,t,e,l)} as s) :: rests -> - currentLoc := l; - s.skind <- If(eb, scanBlock false t, scanBlock false e, l); - s :: scanStmts mainbody rests -(* - | ({skind=Loop(b,l,lb1,lb2)} as s) :: rests -> - currentLoc := l; - s.skind <- Loop(scanBlock false b, l,lb1,lb2); - s :: scanStmts mainbody rests -*) - | ({skind=While(e,b,l)} as s) :: rests -> - currentLoc := l; - s.skind <- While(e, scanBlock false b, l); - s :: scanStmts mainbody rests - | ({skind=DoWhile(e,b,l)} as s) :: rests -> - currentLoc := l; - s.skind <- DoWhile(e, scanBlock false b, l); - s :: scanStmts mainbody rests - | ({skind=For(bInit,e,bIter,b,l)} as s) :: rests -> - currentLoc := l; - s.skind <- For(scanBlock false bInit, e, scanBlock false bIter, - scanBlock false b, l); - s :: scanStmts mainbody rests - | ({skind=Switch(e, b, cases, l)} as s) :: rests -> - currentLoc := l; - s.skind <- Switch(e, scanBlock false b, cases, l); - s :: scanStmts mainbody rests - | ({skind=Block b} as s) :: rests -> - s.skind <- Block (scanBlock false b); - s :: scanStmts mainbody rests - | ({skind=(Goto _ | Instr _ | Continue _ | Break _ - | TryExcept _ | TryFinally _)} as s) - :: rests -> s :: scanStmts mainbody rests - - and scanBlock (mainbody: bool) (b: block) = - { bstmts = scanStmts mainbody b.bstmts; battrs = b.battrs; } - - in - ignore (visitCilBlock dummyVisitor f.sbody) ; (* sets CurrentLoc *) - lastloc := !currentLoc ; (* last location in the function *) - f.sbody <- scanBlock true f.sbody - - -let feature : featureDescr = - { fd_name = "oneRet"; - fd_enabled = Cilutil.doOneRet; - fd_description = "make each function have at most one 'return'" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> - Cil.iterGlobals f (fun glob -> match glob with - Cil.GFun(fd,_) -> oneret fd; - | _ -> ())); - fd_post_check = true; - } diff --git a/cil/src/ext/oneret.mli b/cil/src/ext/oneret.mli deleted file mode 100644 index f98ab4d..0000000 --- a/cil/src/ext/oneret.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* Make sure that there is only one Return statement in the whole body. - * Replace all the other returns with Goto. Make sure that there is a return - * if the function is supposed to return something, and it is not declared to - * not return. *) -val oneret: Cil.fundec -> unit -val feature : Cil.featureDescr diff --git a/cil/src/ext/partial.ml b/cil/src/ext/partial.ml deleted file mode 100644 index 4beca3f..0000000 --- a/cil/src/ext/partial.ml +++ /dev/null @@ -1,851 +0,0 @@ -(* See copyright notice at the end of the file *) -(***************************************************************************** - * Partial Evaluation & Constant Folding - * - * Soundness Assumptions: - * (1) Whole program analysis. You may call functions that are not defined - * (e.g., library functions) but they may not call back. - * (2) An undefined function may not return the address of a function whose - * address is not already taken in the code I can see. - * (3) A function pointer call may only call a function that has its - * address visibly taken in the code I can see. - * - * (More assumptions in the comments below) - *****************************************************************************) -open Cil -open Pretty - -(***************************************************************************** - * A generic signature for Alias Analysis information. Used to compute the - * call graph and do symbolic execution. - ****************************************************************************) -module type AliasInfo = - sig - val can_have_the_same_value : Cil.exp -> Cil.exp -> bool - val resolve_function_pointer : Cil.exp -> (Cil.fundec list) - end - -(***************************************************************************** - * A generic signature for Symbolic Execution execution algorithms. Such - * algorithms are used below to perform constant folding and dead-code - * elimination. You write a "basic-block" symex algorithm, we'll make it - * a whole-program CFG-pruner. - ****************************************************************************) -module type Symex = - sig - type t (* the type of a symex algorithm state object *) - val empty : t (* all values unknown *) - val equal : t -> t -> bool (* are these the same? *) - val assign : t -> Cil.lval -> Cil.exp -> (Cil.exp * t) - (* incorporate an assignment, return the RHS *) - val unassign : t -> Cil.lval -> t - (* lose all information about the given lvalue: assume an - * unknown external value has been assigned to it *) - val assembly : t -> Cil.instr -> t (* handle ASM *) - val assume : t -> Cil.exp -> t (* incorporate an assumption *) - val evaluate : t -> Cil.exp -> Cil.exp (* symbolic evaluation *) - val join : (t list) -> t (* join a bunch of states *) - val call : t -> Cil.fundec -> (Cil.exp list) -> (Cil.exp list * t) - (* we are calling the given function with the given actuals *) - val return : t -> Cil.fundec -> t - (* we are returning from the given function *) - val call_to_unknown_function : t -> t - (* throw away information that may have been changed *) - val debug : t -> unit - end - -(***************************************************************************** - * A generic signature for whole-progam call graphs. - ****************************************************************************) -module type CallGraph = - sig - type t (* the type of a call graph *) - val compute : Cil.file -> t (* file for which we compute the graph *) - val can_call : t -> Cil.fundec -> (Cil.fundec list) - val can_be_called_by : t -> Cil.fundec -> (Cil.fundec list) - val fundec_of_varinfo : t -> Cil.varinfo -> Cil.fundec - end - -(***************************************************************************** - * My cheap-o Alias Analysis. Assume all expressions can have the same - * value and any function with its address taken can be the target of - * any function pointer. - * - * Soundness Assumptions: - * (1) Someone must call "find_all_functions_With_address_taken" before the - * results are valid. This is already done in the code below. - ****************************************************************************) -let all_functions_with_address_taken = ref [] -let find_all_functions_with_address_taken (f : Cil.file) = - iterGlobals f (fun g -> match g with - GFun(fd,_) -> if fd.svar.vaddrof then - all_functions_with_address_taken := fd :: - !all_functions_with_address_taken - | _ -> ()) - -module EasyAlias = - struct - let can_have_the_same_value e1 e2 = true - let resolve_function_pointer e1 = !all_functions_with_address_taken - end - -(***************************************************************************** - * My particular method for computing the Call Graph. - ****************************************************************************) -module EasyCallGraph = functor (A : AliasInfo) -> - struct - type callGraphNode = { - fd : Cil.fundec ; - mutable calledBy : Cil.fundec list ; - mutable calls : Cil.fundec list ; - } - type t = (Cil.varinfo, callGraphNode) Hashtbl.t - - let cgCreateNode cg fundec = - let newnode = { fd = fundec ; calledBy = [] ; calls = [] } in - Hashtbl.add cg fundec.svar newnode - - let cgFindNode cg svar = Hashtbl.find cg svar - - let cgAddEdge cg caller callee = - try - let n1 = cgFindNode cg caller in - let n2 = cgFindNode cg callee in - n1.calls <- n2.fd :: n1.calls ; - n1.calledBy <- n1.fd :: n1.calledBy - with _ -> () - - class callGraphVisitor cg = object - inherit nopCilVisitor - val the_fun = ref None - - method vinst i = - let _ = match i with - Call(_,Lval(Var(callee),NoOffset),_,_) -> begin - (* known function call *) - match !the_fun with - None -> failwith "callGraphVisitor: call outside of any function" - | Some(enclosing) -> cgAddEdge cg enclosing callee - end - | Call(_,e,_,_) -> begin - (* unknown function call *) - match !the_fun with - None -> failwith "callGraphVisitor: call outside of any function" - | Some(enclosing) -> let lst = A.resolve_function_pointer e in - List.iter (fun possible_target_fd -> - cgAddEdge cg enclosing possible_target_fd.svar) lst - end - | _ -> () - in SkipChildren - - method vfunc f = the_fun := Some(f.svar) ; DoChildren - end - - let compute (f : Cil.file) = - let cg = Hashtbl.create 511 in - iterGlobals f (fun g -> match g with - GFun(fd,_) -> cgCreateNode cg fd - | _ -> () - ) ; - visitCilFileSameGlobals (new callGraphVisitor cg) f ; - cg - - let can_call cg fd = - let n = cgFindNode cg fd.svar in n.calls - let can_be_called_by cg fd = - let n = cgFindNode cg fd.svar in n.calledBy - let fundec_of_varinfo cg vi = - let n = cgFindNode cg vi in n.fd - end (* END OF: module EasyCallGraph *) - -(***************************************************************************** - * Necula's Constant Folding Strategem (re-written to be applicative) - * - * Soundness Assumptions: - * (1) Inline assembly does not affect constant folding. - ****************************************************************************) -module OrderedInt = - struct - type t = int - let compare = compare - end -module IntMap = Map.Make(OrderedInt) - -module NeculaFolding = functor (A : AliasInfo) -> - struct - (* Register file. Maps identifiers of local variables to expressions. - * We also remember if the expression depends on memory or depends on - * variables that depend on memory *) - type reg = { - rvi : varinfo ; - rval : exp ; - rmem : bool - } - type t = reg IntMap.t - let empty = IntMap.empty - let equal t1 t2 = (compare t1 t2 = 0) (* use OCAML here *) - let dependsOnMem = ref false - (* Rewrite an expression based on the current register file *) - class rewriteExpClass (regFile : t) = object - inherit nopCilVisitor - method vexpr = function - | Lval (Var v, NoOffset) -> begin - try - let defined = (IntMap.find v.vid regFile) in - if (defined.rmem) then dependsOnMem := true; - (match defined.rval with - | Const(x) -> ChangeTo (defined.rval) - | _ -> DoChildren) - with Not_found -> DoChildren - end - | Lval (Mem _, _) -> dependsOnMem := true; DoChildren - | _ -> DoChildren - end - (* Rewrite an expression and return the new expression along with an - * indication of whether it depends on memory *) - let rewriteExp r (e: exp) : exp * bool = - dependsOnMem := false; - let e' = constFold true (visitCilExpr (new rewriteExpClass r) e) in - e', !dependsOnMem - let eval r e = - let new_e, depends = rewriteExp r e in - new_e - - let setMemory regFile = - (* Get a list of all mappings that depend on memory *) - let depids = ref [] in - IntMap.iter (fun id v -> if v.rmem then depids := id :: !depids) regFile; - (* And remove them from the register file *) - List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids - - let setRegister regFile (v: varinfo) ((e,b): exp * bool) = - IntMap.add v.vid { rvi = v ; rval = e ; rmem = b; } regFile - - let resetRegister regFile (id: int) = - IntMap.remove id regFile - - class findLval lv contains = object - inherit nopCilVisitor - method vlval l = - if l = lv then - (contains := true ; SkipChildren) - else - DoChildren - end - - let removeMappingsThatDependOn regFile l = - (* Get a list of all mappings that depend on l *) - let depids = ref [] in - IntMap.iter (fun id reg -> - let found = ref false in - ignore (visitCilExpr (new findLval l found) reg.rval) ; - if !found then - depids := id :: !depids - ) regFile ; - (* And remove them from the register file *) - List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids - - let assign r l e = - let (newe,b) = rewriteExp r e in - let r' = match l with - (Var v, NoOffset) -> - let r'' = setRegister r v (newe,b) in - removeMappingsThatDependOn r'' l - | (Mem _, _) -> setMemory r - | _ -> r - in newe, r' - - let unassign r l = - let r' = match l with - (Var v, NoOffset) -> - let r'' = resetRegister r v.vid in - removeMappingsThatDependOn r'' l - | (Mem _, _) -> setMemory r - | _ -> r - in r' - - let assembly r i = r (* no-op in Necula-world *) - let assume r e = r (* no-op in Necula-world *) - - let evaluate r e = - let (newe,_) = rewriteExp r e in - newe - - (* Join two symex states *) - let join2 (r1 : t) (r2 : t) = - let keep = ref [] in - IntMap.iter (fun id reg -> - try - let reg' = IntMap.find id r2 in - if reg'.rval = reg.rval && reg'.rmem = reg.rmem then - keep := (id,reg) :: !keep - with _ -> () - ) r1 ; - List.fold_left (fun acc (id,v) -> - IntMap.add id v acc) (IntMap.empty) !keep - - let join (lst : t list) = match lst with - [] -> failwith "empty list" - | r :: tl -> List.fold_left - (fun (acc : t) (elt : t) -> join2 acc elt) r tl - - let call r fd el = - let new_arg_list = ref [] in - let final_r = List.fold_left2 (fun r vi e -> - let newe, r' = assign r ((Var(vi),NoOffset)) e in - new_arg_list := newe :: !new_arg_list ; - r' - ) r fd.sformals el in - (List.rev !new_arg_list), final_r - - let return r fd = - let regFile = - List.fold_left (fun r vi -> IntMap.remove vi.vid r) r fd.sformals - in - (* Get a list of all globals *) - let depids = ref [] in - IntMap.iter (fun vid reg -> - if reg.rvi.vglob || reg.rvi.vaddrof then depids := vid :: !depids - ) regFile ; - (* And remove them from the register file *) - List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids - - - let call_to_unknown_function r = - setMemory r - - let debug r = - IntMap.iter (fun key reg -> - ignore (Pretty.printf "%s <- %a (%b)@!" reg.rvi.vname d_exp reg.rval reg.rmem) - ) r - end (* END OF: NeculaFolding *) - -(***************************************************************************** - * A transformation to make every function call end its statement. So - * { x=1; Foo(); y=1; } - * becomes at least: - * { { x=1; Foo(); } - * { y=1; } } - * But probably more like: - * { { x=1; } { Foo(); } { y=1; } } - ****************************************************************************) -let rec contains_call il = match il with - [] -> false - | Call(_) :: tl -> true - | _ :: tl -> contains_call tl - -class callBBVisitor = object - inherit nopCilVisitor - - method vstmt s = - match s.skind with - Instr(il) when contains_call il -> begin - let list_of_stmts = List.map (fun one_inst -> - mkStmtOneInstr one_inst) il in - let block = mkBlock list_of_stmts in - ChangeDoChildrenPost(s, (fun _ -> - s.skind <- Block(block) ; - s)) - end - | _ -> DoChildren - - method vvdec _ = SkipChildren - method vexpr _ = SkipChildren - method vlval _ = SkipChildren - method vtype _ = SkipChildren -end - -let calls_end_basic_blocks f = - let thisVisitor = new callBBVisitor in - visitCilFileSameGlobals thisVisitor f - -(***************************************************************************** - * A transformation that gives each variable a unique identifier. - ****************************************************************************) -class vidVisitor = object - inherit nopCilVisitor - val count = ref 0 - - method vvdec vi = - vi.vid <- !count ; - incr count ; SkipChildren -end - -let globally_unique_vids f = - let thisVisitor = new vidVisitor in - visitCilFileSameGlobals thisVisitor f - -(***************************************************************************** - * The Weimeric Partial Evaluation Data-Flow Engine - * - * This functor performs flow-sensitive, context-insensitive whole-program - * data-flow analysis with an eye toward partial evaluation and constant - * folding. - * - * Toposort the whole-program inter-procedural CFG to compute - * (1) the number of actual predecessors for each statement - * (2) the global toposort ordering - * - * Perform standard data-flow analysis (joins, etc) on the ICFG until you - * hit a fixed point. If this changed the structure of the ICFG (by - * removing an IF-branch or an empty function call), redo the whole thing. - * - * Soundness Assumptions: - * (1) A "call instruction" is the last thing in its statement. - * Use "calls_end_basic_blocks" to get this. cil/src/main.ml does - * this when you pass --makeCFG. - * (2) All variables have globally unique identifiers. - * Use "globally_unique_vids" to get this. cil/src/main.ml does - * this when you pass --makeCFG. - * (3) This may not be a strict soundness requirement, but I wrote this - * assuming that the input file has all switch/break/continue - * statements removed. - ****************************************************************************) -module MakePartial = - functor (S : Symex) -> - functor (C : CallGraph) -> - functor (A : AliasInfo) -> - struct - - let debug = false - - (* We keep this information about every statement. Ideally this should - * be put in the stmt itself, but CIL doesn't give us space. *) - type sinfo = { (* statement info *) - incoming_state : (int, S.t) Hashtbl.t ; - (* mapping from stmt.sid to Symex.state *) - reachable_preds : (int, bool) Hashtbl.t ; - (* basically a set of all of the stmt.sids that can really - * reach this statement *) - mutable last_used_state : S.t option ; - (* When we last did the Post() of this statement, what - * incoming state did we use? If our new incoming state is - * the same, we don't have to do it again. *) - mutable priority : int ; - (* Whole-program toposort priority. High means "do me first". - * The first stmt in "main()" will have the highest priority. - *) - } - let sinfo_ht = Hashtbl.create 511 - let clear_sinfo () = Hashtbl.clear sinfo_ht - - (* We construct sinfo nodes lazily: if you ask for one that isn't - * there, we build it. *) - let get_sinfo stmt = - try - Hashtbl.find sinfo_ht stmt.sid - with _ -> - let new_sinfo = { incoming_state = Hashtbl.create 3 ; - reachable_preds = Hashtbl.create 3 ; - last_used_state = None ; - priority = (-1) ; } in - Hashtbl.add sinfo_ht stmt.sid new_sinfo ; - new_sinfo - - (* Topological Sort is a DFS in which you assign a priority right as - * you finished visiting the children. While we're there we compute - * the actual number of unique predecessors for each statement. The CIL - * information may be out of date because we keep changing the CFG by - * removing IFs and whatnot. *) - let toposort_counter = ref 1 - let add_edge s1 s2 = - let si2 = get_sinfo s2 in - Hashtbl.replace si2.reachable_preds s1.sid true - - let rec toposort c stmt = - let si = get_sinfo stmt in - if si.priority >= 0 then - () (* already visited! *) - else begin - si.priority <- 0 ; (* currently visiting *) - (* handle function calls in this basic block *) - (match stmt.skind with - (Instr(il)) -> - List.iter (fun i -> - let fd_list = match i with - Call(_,Lval(Var(vi),NoOffset),_,_) -> - begin - try - let fd = C.fundec_of_varinfo c vi in - [fd] - with e -> [] (* calling external function *) - end - | Call(_,e,_,_) -> - A.resolve_function_pointer e - | _ -> [] - in - List.iter (fun fd -> - if List.length fd.sbody.bstmts > 0 then - let fun_stmt = List.hd fd.sbody.bstmts in - add_edge stmt fun_stmt ; - toposort c fun_stmt - ) fd_list - ) il - | _ -> ()); - List.iter (fun succ -> - add_edge stmt succ ; toposort c succ) stmt.succs ; - si.priority <- !toposort_counter ; - incr toposort_counter - end - - (* we set this to true whenever we eliminate an IF or otherwise - * change the CFG *) - let changed_cfg = ref false - - (* Partially evaluate / constant fold a statement. Basically this just - * asks the Symex algorithm to evaluate the RHS in the current state - * and then compute a new state that incorporates the assignment. - * - * However, we have special handling for ifs and calls. If we can - * evaluate an if predicate to a constant, we remove the if. - * - * If we are going to make a call to a function with an empty body, we - * remove the function call. *) - let partial_stmt c state stmt handle_funcall = - let result = match stmt.skind with - Instr(il) -> - let state = ref state in - let new_il = List.map (fun i -> - if debug then begin - ignore (Pretty.printf "Instr %a@!" d_instr i ) - end ; - match i with - | Set(l,e,loc) -> - let e', state' = S.assign !state l e in - state := state' ; - [Set(l,e',loc)] - | Call(lo,(Lval(Var(vi),NoOffset)),al,loc) -> - let result = begin - try - let fd = C.fundec_of_varinfo c vi in - begin - match fd.sbody.bstmts with - [] -> [] (* no point in making this call *) - | hd :: tl -> - let al', state' = S.call !state fd al in - handle_funcall stmt hd state' ; - let state'' = S.return state' fd in - state := state'' ; - [Call(lo,(Lval(Var(vi),NoOffset)),al',loc)] - end - with e -> - let state'' = S.call_to_unknown_function !state in - let al' = List.map (S.evaluate !state) al in - state := state'' ; - [Call(lo,(Lval(Var(vi),NoOffset)),al',loc)] - end in - (* handle return value *) - begin - match lo with - Some(lv) -> state := S.unassign !state lv - | _ -> () - end ; - result - | Call(lo,f,al,loc) -> - let al' = List.map (S.evaluate !state) al in - state := S.call_to_unknown_function !state ; - (match lo with - Some(lv) -> state := S.unassign !state lv - | None -> ()) ; - [Call(lo,f,al',loc)] - | Asm(_) -> state := S.assembly !state i ; [i] - ) il in - stmt.skind <- Instr(List.flatten new_il) ; - if debug then begin - ignore (Pretty.printf "New Stmt is %a@!" d_stmt stmt) ; - end ; - !state - - | If(e,b1,b2,loc) -> - let e' = S.evaluate state e in - (* Pretty.printf "%a evals to %a\n" d_exp e d_exp e' ; *) - - (* helper function to remove an IF branch *) - let remove b remains = begin - changed_cfg := true ; - (match b.bstmts with - | [] -> () - | hd :: tl -> - stmt.succs <- List.filter (fun succ -> succ.sid <> hd.sid) - stmt.succs - ) - end in - - if (e' = one) then begin - if b2.bstmts = [] && b2.battrs = [] then begin - stmt.skind <- Block(b1) ; - match b1.bstmts with - [] -> failwith "partial: completely empty if" - | hd :: tl -> stmt.succs <- [hd] - end else - stmt.skind <- Block( - { bstmts = - [ mkStmt (Block(b1)) ; - mkStmt (If(zero,b2,{bstmts=[];battrs=[];},loc)) ] ; - battrs = [] } ) ; - remove b2 b1 ; - state - end else if (e' = zero) then begin - if b1.bstmts = [] && b1.battrs = [] then begin - stmt.skind <- Block(b2) ; - match b2.bstmts with - [] -> failwith "partial: completely empty if" - | hd :: tl -> stmt.succs <- [hd] - end else - stmt.skind <- Block( - { bstmts = - [ mkStmt (Block(b2)) ; - mkStmt (If(zero,b1,{bstmts=[];battrs=[];},loc)) ] ; - battrs = [] } ) ; - remove b1 b2 ; - state - end else begin - stmt.skind <- If(e',b1,b2,loc) ; - state - end - - | Return(Some(e),loc) -> - let e' = S.evaluate state e in - stmt.skind <- Return(Some(e'),loc) ; - state - - | Block(b) -> - if debug && List.length stmt.succs > 1 then begin - ignore (Pretty.printf "(%a) has successors [%a]@!" - d_stmt stmt - (docList ~sep:(chr '@') (d_stmt ())) - stmt.succs) - end ; - state - - | _ -> state - in result - - (* - * This is the main conceptual entry-point for the partial evaluation - * data-flow functor. - *) - let dataflow (file : Cil.file) (* whole program *) - (c : C.t) (* control-flow graph *) - (initial_state : S.t) (* any assumptions? *) - (initial_stmt : Cil.stmt) (* entry point *) - = begin - (* count the total number of statements in the program *) - let num_stmts = ref 1 in - iterGlobals file (fun g -> match g with - GFun(fd,_) -> begin - match fd.smaxstmtid with - Some(i) -> if i > !num_stmts then num_stmts := i - | None -> () - end - | _ -> () - ) ; - (if debug then - Printf.printf "Dataflow: at most %d statements in program\n" !num_stmts); - - (* create a priority queue in which to store statements *) - let worklist = Heap.create !num_stmts in - - let finished = ref false in - let passes = ref 0 in - - (* add something to the work queue *) - let enqueue caller callee state = begin - let si = get_sinfo callee in - Hashtbl.replace si.incoming_state caller.sid state ; - Heap.insert worklist si.priority callee - end in - - (* we will be finished when we complete a round of data-flow that - * does not change the ICFG *) - while not !finished do - clear_sinfo () ; - incr passes ; - - (* we must recompute the ordering and the predecessor information - * because we may have changed it by removing IFs *) - (if debug then Printf.printf "Dataflow: Topological Sorting & Reachability\n" ); - toposort c initial_stmt ; - - let initial_si = get_sinfo initial_stmt in - Heap.insert worklist initial_si.priority initial_stmt ; - - while not (Heap.is_empty worklist) do - let (p,s) = Heap.extract_max worklist in - if debug then begin - ignore (Pretty.printf "Working on stmt %d (%a) %a@!" - s.sid - (docList ~sep:(chr ',' ++ break) (fun s -> dprintf "%d" s.sid)) - s.succs - d_stmt s) ; - flush stdout ; - end ; - let si = get_sinfo s in - - (* Even though this stmt is on the worklist, we may not have - * to do anything with it if the join of all of the incoming - * states is the same as the last state we used here. *) - let must_recompute, incoming_state = - begin - let list_of_incoming_states = ref [] in - Hashtbl.iter (fun true_pred_sid b -> - let this_pred_state = - try - Hashtbl.find si.incoming_state true_pred_sid - with _ -> - (* this occurs when we're evaluating a statement and we - * have not yet evaluated all of its predecessors (the - * first time we look at a loop head, say). We must be - * conservative. We'll come back later with better - * information (as we work toward the fix-point). *) - S.empty - in - if debug then begin - Printf.printf " Incoming State from %d\n" true_pred_sid ; - S.debug this_pred_state ; - flush stdout ; - end ; - list_of_incoming_states := this_pred_state :: - !list_of_incoming_states - ) si.reachable_preds ; - let merged_incoming_state = - if !list_of_incoming_states = [] then - (* this occurs when we're looking at the first statement - * in "main" -- it has no preds *) - initial_state - else - S.join !list_of_incoming_states - in - if debug then begin - Printf.printf " Merged State:\n" ; - S.debug merged_incoming_state ; - flush stdout ; - end ; - let must_recompute = match si.last_used_state with - None -> true - | Some(last) -> not (S.equal merged_incoming_state last) - in must_recompute, merged_incoming_state - end - in - if must_recompute then begin - si.last_used_state <- Some(incoming_state) ; - let outgoing_state = - (* partially evaluate and optimize the statement *) - partial_stmt c incoming_state s enqueue in - let fresh_succs = s.succs in - (* touch every successor so that we will reconsider it *) - List.iter (fun succ -> - enqueue s succ outgoing_state - ) fresh_succs ; - end else begin - if debug then begin - Printf.printf "No need to recompute.\n" - end - end - done ; - (if debug then Printf.printf "Dataflow: Pass %d Complete\n" !passes) ; - if !changed_cfg then begin - (if debug then Printf.printf "Dataflow: Restarting (CFG Changed)\n") ; - changed_cfg := false - end else - finished := true - done ; - (if debug then Printf.printf "Dataflow: Completed (%d passes)\n" !passes) - - end - - let simplify file c fd (assumptions : (Cil.lval * Cil.exp) list) = - let starting_state = List.fold_left (fun s (l,e) -> - let e',s' = S.assign s l e in - s' - ) S.empty assumptions in - dataflow file c starting_state (List.hd fd.sbody.bstmts) - - end - - -(* - * Currently our partial-eval optimizer is built out of basically nothing. - * The alias analysis is fake, the call grpah is cheap, and we're using - * George's old basic-block symex. Still, it works. - *) -(* Don't you love Functor application? *) -module BasicCallGraph = EasyCallGraph(EasyAlias) -module BasicSymex = NeculaFolding(EasyAlias) -module BasicPartial = MakePartial(BasicSymex)(BasicCallGraph)(EasyAlias) - -(* - * A very easy entry-point to partial evaluation/symbolic execution. - * You pass the Cil file and a list of assumptions (lvalue, exp pairs that - * should be treated as assignments that occur before the program starts). - * - * We partially evaluate and optimize starting from "main". The Cil.file - * is modified in place. - *) -let partial (f : Cil.file) (assumptions : (Cil.lval * Cil.exp) list) = - try - find_all_functions_with_address_taken f ; - let c = BasicCallGraph.compute f in - try - iterGlobals f (fun g -> match g with - GFun(fd,_) when fd.svar.vname = "main" -> - BasicPartial.simplify f c fd assumptions - | _ -> ()) ; - with e -> begin - Printf.printf "Error in DataFlow: %s\n" (Printexc.to_string e) ; - raise e - end - with e -> begin - Printf.printf "Error in Partial: %s\n" (Printexc.to_string e) ; - raise e - end - -let feature : featureDescr = - { fd_name = "partial"; - fd_enabled = Cilutil.doPartial; - fd_description = "interprocedural partial evaluation and constant folding" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> - if not !Cilutil.makeCFG then begin - Errormsg.s (Errormsg.error "--dopartial: you must also specify --domakeCFG\n") - end ; - partial f [] ) ; - fd_post_check = false; - } - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) diff --git a/cil/src/ext/pta/golf.ml b/cil/src/ext/pta/golf.ml deleted file mode 100644 index 5ea47ff..0000000 --- a/cil/src/ext/pta/golf.ml +++ /dev/null @@ -1,1657 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(***********************************************************************) -(* *) -(* Exceptions *) -(* *) -(***********************************************************************) - -exception Inconsistent (* raised if constraint system is inconsistent *) -exception WellFormed (* raised if types are not well-formed *) -exception NoContents -exception APFound (* raised if an alias pair is found, a control - flow exception *) - - -module U = Uref -module S = Setp -module H = Hashtbl -module Q = Queue - - -(** Subtyping kinds *) -type polarity = - Pos - | Neg - | Sub - -(** Path kinds, for CFL reachability *) -type pkind = - Positive - | Negative - | Match - | Seed - -(** Context kinds -- open or closed *) -type context = - Open - | Closed - -(* A configuration is a context (open or closed) coupled with a pair - of stamps representing a state in the cartesian product DFA. *) -type configuration = context * int * int - -module ConfigHash = -struct - type t = configuration - let equal t t' = t = t' - let hash t = Hashtbl.hash t -end - -module CH = H.Make (ConfigHash) - -type config_map = unit CH.t - -(** Generic bounds *) -type 'a bound = {index : int; info : 'a U.uref} - -(** For label paths. *) -type 'a path = { - kind : pkind; - reached_global : bool; - head : 'a U.uref; - tail : 'a U.uref -} - -module Bound = -struct - type 'a t = 'a bound - let compare (x : 'a t) (y : 'a t) = - if U.equal (x.info, y.info) then x.index - y.index - else Pervasives.compare (U.deref x.info) (U.deref y.info) -end - -module Path = -struct - type 'a t = 'a path - let compare (x : 'a t) (y : 'a t) = - if U.equal (x.head, y.head) then - begin - if U.equal (x.tail, y.tail) then - begin - if x.reached_global = y.reached_global then - Pervasives.compare x.kind y.kind - else Pervasives.compare x.reached_global y.reached_global - end - else Pervasives.compare (U.deref x.tail) (U.deref y.tail) - end - else Pervasives.compare (U.deref x.head) (U.deref y.head) -end - -module B = S.Make (Bound) - -module P = S.Make (Path) - -type 'a boundset = 'a B.t - -type 'a pathset = 'a P.t - -(** Constants, which identify elements in points-to sets *) -(** jk : I'd prefer to make this an 'a constant and specialize it to varinfo - for use with the Cil frontend, but for now, this will do *) -type constant = int * string * Cil.varinfo - -module Constant = -struct - type t = constant - let compare (xid, _, _) (yid, _, _) = xid - yid -end -module C = Set.Make (Constant) - -(** Sets of constants. Set union is used when two labels containing - constant sets are unified *) -type constantset = C.t - -type lblinfo = { - mutable l_name: string; - (** either empty or a singleton, the initial location for this label *) - loc : constantset; - (** Name of this label *) - l_stamp : int; - (** Unique integer for this label *) - mutable l_global : bool; - (** True if this location is globally accessible *) - mutable aliases: constantset; - (** Set of constants (tags) for checking aliases *) - mutable p_lbounds: lblinfo boundset; - (** Set of umatched (p) lower bounds *) - mutable n_lbounds: lblinfo boundset; - (** Set of unmatched (n) lower bounds *) - mutable p_ubounds: lblinfo boundset; - (** Set of umatched (p) upper bounds *) - mutable n_ubounds: lblinfo boundset; - (** Set of unmatched (n) upper bounds *) - mutable m_lbounds: lblinfo boundset; - (** Set of matched (m) lower bounds *) - mutable m_ubounds: lblinfo boundset; - (** Set of matched (m) upper bounds *) - - mutable m_upath: lblinfo pathset; - mutable m_lpath: lblinfo pathset; - mutable n_upath: lblinfo pathset; - mutable n_lpath: lblinfo pathset; - mutable p_upath: lblinfo pathset; - mutable p_lpath: lblinfo pathset; - - mutable l_seeded : bool; - mutable l_ret : bool; - mutable l_param : bool; -} - -(** Constructor labels *) -and label = lblinfo U.uref - -(** The type of lvalues. *) -type lvalue = { - l: label; - contents: tau -} - -and vinfo = { - v_stamp : int; - v_name : string; - - mutable v_hole : (int,unit) H.t; - mutable v_global : bool; - mutable v_mlbs : tinfo boundset; - mutable v_mubs : tinfo boundset; - mutable v_plbs : tinfo boundset; - mutable v_pubs : tinfo boundset; - mutable v_nlbs : tinfo boundset; - mutable v_nubs : tinfo boundset -} - -and rinfo = { - r_stamp : int; - rl : label; - points_to : tau; - mutable r_global: bool; -} - -and finfo = { - f_stamp : int; - fl : label; - ret : tau; - mutable args : tau list; - mutable f_global : bool; -} - -and pinfo = { - p_stamp : int; - ptr : tau; - lam : tau; - mutable p_global : bool; -} - -and tinfo = Var of vinfo - | Ref of rinfo - | Fun of finfo - | Pair of pinfo - -and tau = tinfo U.uref - -type tconstraint = Unification of tau * tau - | Leq of tau * (int * polarity) * tau - - -(** Association lists, used for printing recursive types. The first element - is a type that has been visited. The second element is the string - representation of that type (so far). If the string option is set, then - this type occurs within itself, and is associated with the recursive var - name stored in the option. When walking a type, add it to an association - list. - - Example : suppose we have the constraint 'a = ref('a). The type is unified - via cyclic unification, and would loop infinitely if we attempted to print - it. What we want to do is print the type u rv. ref(rv). This is accomplished - in the following manner: - - -- ref('a) is visited. It is not in the association list, so it is added - and the string "ref(" is stored in the second element. We recurse to print - the first argument of the constructor. - - -- In the recursive call, we see that 'a (or ref('a)) is already in the - association list, so the type is recursive. We check the string option, - which is None, meaning that this is the first recurrence of the type. We - create a new recursive variable, rv and set the string option to 'rv. Next, - we prepend u rv. to the string representation we have seen before, "ref(", - and return "rv" as the string representation of this type. - - -- The string so far is "u rv.ref(". The recursive call returns, and we - complete the type by printing the result of the call, "rv", and ")" - - In a type where the recursive variable appears twice, e.g. 'a = pair('a,'a), - the second time we hit 'a, the string option will be set, so we know to - reuse the same recursive variable name. -*) -type association = tau * string ref * string option ref - -module PathHash = -struct - type t = int list - let equal t t' = t = t' - let hash t = Hashtbl.hash t -end - -module PH = H.Make (PathHash) - -(***********************************************************************) -(* *) -(* Global Variables *) -(* *) -(***********************************************************************) - -(** Print the instantiations constraints. *) -let print_constraints : bool ref = ref false - -(** If true, print all constraints (including induced) and show - additional debug output. *) -let debug = ref false - -(** Just debug all the constraints (including induced) *) -let debug_constraints = ref false - -(** Debug smart alias queries *) -let debug_aliases = ref false - -let smart_aliases = ref false - -(** If true, make the flow step a no-op *) -let no_flow = ref false - -(** If true, disable subtyping (unification at all levels) *) -let no_sub = ref false - -(** If true, treat indexed edges as regular subtyping *) -let analyze_mono = ref true - -(** A list of equality constraints. *) -let eq_worklist : tconstraint Q.t = Q.create () - -(** A list of leq constraints. *) -let leq_worklist : tconstraint Q.t = Q.create () - -let path_worklist : (lblinfo path) Q.t = Q.create () - -let path_hash : (lblinfo path) PH.t = PH.create 32 - -(** A count of the constraints introduced from the AST. Used for debugging. *) -let toplev_count = ref 0 - -(** A hashtable containing stamp pairs of labels that must be aliased. *) -let cached_aliases : (int * int,unit) H.t = H.create 64 - -(** A hashtable mapping pairs of tau's to their join node. *) -let join_cache : (int * int, tau) H.t = H.create 64 - -(***********************************************************************) -(* *) -(* Utility Functions *) -(* *) -(***********************************************************************) - -let find = U.deref - -let die s = - Printf.printf "*******\nAssertion failed: %s\n*******\n" s; - assert false - -let fresh_appsite : (unit -> int) = - let appsite_index = ref 0 in - fun () -> - incr appsite_index; - !appsite_index - -(** Generate a unique integer. *) -let fresh_index : (unit -> int) = - let counter = ref 0 in - fun () -> - incr counter; - !counter - -let fresh_stamp : (unit -> int) = - let stamp = ref 0 in - fun () -> - incr stamp; - !stamp - -(** Return a unique integer representation of a tau *) -let get_stamp (t : tau) : int = - match find t with - Var v -> v.v_stamp - | Ref r -> r.r_stamp - | Pair p -> p.p_stamp - | Fun f -> f.f_stamp - -(** Negate a polarity. *) -let negate (p : polarity) : polarity = - match p with - Pos -> Neg - | Neg -> Pos - | Sub -> die "negate" - -(** Consistency checks for inferred types *) -let pair_or_var (t : tau) = - match find t with - Pair _ -> true - | Var _ -> true - | _ -> false - -let ref_or_var (t : tau) = - match find t with - Ref _ -> true - | Var _ -> true - | _ -> false - -let fun_or_var (t : tau) = - match find t with - Fun _ -> true - | Var _ -> true - | _ -> false - - - -(** Apply [f] structurally down [t]. Guaranteed to terminate, even if [t] - is recursive *) -let iter_tau f t = - let visited : (int,tau) H.t = H.create 4 in - let rec iter_tau' t = - if H.mem visited (get_stamp t) then () else - begin - f t; - H.add visited (get_stamp t) t; - match U.deref t with - Pair p -> - iter_tau' p.ptr; - iter_tau' p.lam - | Fun f -> - List.iter iter_tau' (f.args); - iter_tau' f.ret - | Ref r -> iter_tau' r.points_to - | _ -> () - end - in - iter_tau' t - -(* Extract a label's bounds according to [positive] and [upper]. *) -let get_bounds (p :polarity ) (upper : bool) (l : label) : lblinfo boundset = - let li = find l in - match p with - Pos -> if upper then li.p_ubounds else li.p_lbounds - | Neg -> if upper then li.n_ubounds else li.n_lbounds - | Sub -> if upper then li.m_ubounds else li.m_lbounds - -let equal_tau (t : tau) (t' : tau) = - get_stamp t = get_stamp t' - -let get_label_stamp (l : label) : int = - (find l).l_stamp - -(** Return true if [t] is global (treated monomorphically) *) -let get_global (t : tau) : bool = - match find t with - Var v -> v.v_global - | Ref r -> r.r_global - | Pair p -> p.p_global - | Fun f -> f.f_global - -let is_ret_label l = (find l).l_ret || (find l).l_global (* todo - check *) - -let is_param_label l = (find l).l_param || (find l).l_global - -let is_global_label l = (find l).l_global - -let is_seeded_label l = (find l).l_seeded - -let set_global_label (l : label) (b : bool) : unit = - assert ((not (is_global_label l)) || b); - (U.deref l).l_global <- b - -(** Aliases for set_global *) -let global_tau = get_global - - -(** Get_global for lvalues *) -let global_lvalue lv = get_global lv.contents - - - -(***********************************************************************) -(* *) -(* Printing Functions *) -(* *) -(***********************************************************************) - -let string_of_configuration (c, i, i') = - let context = match c with - Open -> "O" - | Closed -> "C" - in - Printf.sprintf "(%s,%d,%d)" context i i' - -let string_of_polarity p = - match p with - Pos -> "+" - | Neg -> "-" - | Sub -> "M" - -(** Convert a label to a string, short representation *) -let string_of_label (l : label) : string = - "\"" ^ (find l).l_name ^ "\"" - -(** Return true if the element [e] is present in the association list, - according to uref equality *) -let rec assoc_list_mem (e : tau) (l : association list) = - match l with - | [] -> None - | (h, s, so) :: t -> - if U.equal (h,e) then Some (s, so) else assoc_list_mem e t - -(** Given a tau, create a unique recursive variable name. This should always - return the same name for a given tau *) -let fresh_recvar_name (t : tau) : string = - match find t with - Pair p -> "rvp" ^ string_of_int p.p_stamp - | Ref r -> "rvr" ^ string_of_int r.r_stamp - | Fun f -> "rvf" ^ string_of_int f.f_stamp - | _ -> die "fresh_recvar_name" - - -(** Return a string representation of a tau, using association lists. *) -let string_of_tau (t : tau) : string = - let tau_map : association list ref = ref [] in - let rec string_of_tau' t = - match assoc_list_mem t !tau_map with - Some (s, so) -> (* recursive type. see if a var name has been set *) - begin - match !so with - None -> - let rv = fresh_recvar_name t in - s := "u " ^ rv ^ "." ^ !s; - so := Some rv; - rv - | Some rv -> rv - end - | None -> (* type's not recursive. Add it to the assoc list and cont. *) - let s = ref "" - and so : string option ref = ref None in - tau_map := (t, s, so) :: !tau_map; - begin - match find t with - Var v -> s := v.v_name; - | Pair p -> - assert (ref_or_var p.ptr); - assert (fun_or_var p.lam); - s := "{"; - s := !s ^ string_of_tau' p.ptr; - s := !s ^ ","; - s := !s ^ string_of_tau' p.lam; - s := !s ^"}" - | Ref r -> - assert (pair_or_var r.points_to); - s := "ref(|"; - s := !s ^ string_of_label r.rl; - s := !s ^ "|,"; - s := !s ^ string_of_tau' r.points_to; - s := !s ^ ")" - | Fun f -> - assert (pair_or_var f.ret); - let rec string_of_args = function - h :: [] -> - assert (pair_or_var h); - s := !s ^ string_of_tau' h - | h :: t -> - assert (pair_or_var h); - s := !s ^ string_of_tau' h ^ ","; - string_of_args t - | [] -> () - in - s := "fun(|"; - s := !s ^ string_of_label f.fl; - s := !s ^ "|,"; - s := !s ^ "<"; - if List.length f.args > 0 then string_of_args f.args - else s := !s ^ "void"; - s := !s ^">,"; - s := !s ^ string_of_tau' f.ret; - s := !s ^ ")" - end; - tau_map := List.tl !tau_map; - !s - in - string_of_tau' t - -(** Convert an lvalue to a string *) -let rec string_of_lvalue (lv : lvalue) : string = - let contents = string_of_tau lv.contents - and l = string_of_label lv.l in - assert (pair_or_var lv.contents); (* do a consistency check *) - Printf.sprintf "[%s]^(%s)" contents l - -let print_path (p : lblinfo path) : unit = - let string_of_pkind = function - Positive -> "p" - | Negative -> "n" - | Match -> "m" - | Seed -> "s" - in - Printf.printf - "%s --%s--> %s (%d) : " - (string_of_label p.head) - (string_of_pkind p.kind) - (string_of_label p.tail) - (PathHash.hash p) - -(** Print a list of tau elements, comma separated *) -let rec print_tau_list (l : tau list) : unit = - let rec print_t_strings = function - h :: [] -> print_endline h - | h :: t -> - print_string h; - print_string ", "; - print_t_strings t - | [] -> () - in - print_t_strings (List.map string_of_tau l) - -let print_constraint (c : tconstraint) = - match c with - Unification (t, t') -> - let lhs = string_of_tau t - and rhs = string_of_tau t' in - Printf.printf "%s == %s\n" lhs rhs - | Leq (t, (i, p), t') -> - let lhs = string_of_tau t - and rhs = string_of_tau t' in - Printf.printf "%s <={%d,%s} %s\n" lhs i (string_of_polarity p) rhs - -(***********************************************************************) -(* *) -(* Type Operations -- these do not create any constraints *) -(* *) -(***********************************************************************) - -(** Create an lvalue with label [lbl] and tau contents [t]. *) -let make_lval (lbl, t : label * tau) : lvalue = - {l = lbl; contents = t} - -let make_label_int (is_global : bool) (name :string) (vio : Cil.varinfo option) : label = - let locc = - match vio with - Some vi -> C.add (fresh_index (), name, vi) C.empty - | None -> C.empty - in - U.uref { - l_name = name; - l_global = is_global; - l_stamp = fresh_stamp (); - loc = locc; - aliases = locc; - p_ubounds = B.empty; - p_lbounds = B.empty; - n_ubounds = B.empty; - n_lbounds = B.empty; - m_ubounds = B.empty; - m_lbounds = B.empty; - m_upath = P.empty; - m_lpath = P.empty; - n_upath = P.empty; - n_lpath = P.empty; - p_upath = P.empty; - p_lpath = P.empty; - l_seeded = false; - l_ret = false; - l_param = false - } - -(** Create a new label with name [name]. Also adds a fresh constant - with name [name] to this label's aliases set. *) -let make_label (is_global : bool) (name : string) (vio : Cil.varinfo option) : label = - make_label_int is_global name vio - -(** Create a new label with an unspecified name and an empty alias set. *) -let fresh_label (is_global : bool) : label = - let index = fresh_index () in - make_label_int is_global ("l_" ^ string_of_int index) None - -(** Create a fresh bound (edge in the constraint graph). *) -let make_bound (i, a : int * label) : lblinfo bound = - {index = i; info = a} - -let make_tau_bound (i, a : int * tau) : tinfo bound = - {index = i; info = a} - -(** Create a fresh named variable with name '[name]. *) -let make_var (b: bool) (name : string) : tau = - U.uref (Var {v_name = ("'" ^ name); - v_hole = H.create 8; - v_stamp = fresh_index (); - v_global = b; - v_mlbs = B.empty; - v_mubs = B.empty; - v_plbs = B.empty; - v_pubs = B.empty; - v_nlbs = B.empty; - v_nubs = B.empty}) - -(** Create a fresh unnamed variable (name will be 'fv). *) -let fresh_var (is_global : bool) : tau = - make_var is_global ("fv" ^ string_of_int (fresh_index ())) - -(** Create a fresh unnamed variable (name will be 'fi). *) -let fresh_var_i (is_global : bool) : tau = - make_var is_global ("fi" ^ string_of_int (fresh_index())) - -(** Create a Fun constructor. *) -let make_fun (lbl, a, r : label * (tau list) * tau) : tau = - U.uref (Fun {fl = lbl; - f_stamp = fresh_index (); - f_global = false; - args = a; - ret = r }) - -(** Create a Ref constructor. *) -let make_ref (lbl,pt : label * tau) : tau = - U.uref (Ref {rl = lbl; - r_stamp = fresh_index (); - r_global = false; - points_to = pt}) - -(** Create a Pair constructor. *) -let make_pair (p,f : tau * tau) : tau = - U.uref (Pair {ptr = p; - p_stamp = fresh_index (); - p_global = false; - lam = f}) - -(** Copy the toplevel constructor of [t], putting fresh variables in each - argement of the constructor. *) -let copy_toplevel (t : tau) : tau = - match find t with - Pair _ -> make_pair (fresh_var_i false, fresh_var_i false) - | Ref _ -> make_ref (fresh_label false, fresh_var_i false) - | Fun f -> - let fresh_fn = fun _ -> fresh_var_i false in - make_fun (fresh_label false, - List.map fresh_fn f.args, fresh_var_i false) - | _ -> die "copy_toplevel" - - -let has_same_structure (t : tau) (t' : tau) = - match find t, find t' with - Pair _, Pair _ -> true - | Ref _, Ref _ -> true - | Fun _, Fun _ -> true - | Var _, Var _ -> true - | _ -> false - - -let pad_args (f, f' : finfo * finfo) : unit = - let padding = ref ((List.length f.args) - (List.length f'.args)) - in - if !padding == 0 then () - else - let to_pad = - if !padding > 0 then f' else (padding := -(!padding); f) - in - for i = 1 to !padding do - to_pad.args <- to_pad.args @ [fresh_var false] - done - - -let pad_args2 (fi, tlr : finfo * tau list ref) : unit = - let padding = ref (List.length fi.args - List.length !tlr) - in - if !padding == 0 then () - else - if !padding > 0 then - for i = 1 to !padding do - tlr := !tlr @ [fresh_var false] - done - else - begin - padding := -(!padding); - for i = 1 to !padding do - fi.args <- fi.args @ [fresh_var false] - done - end - -(***********************************************************************) -(* *) -(* Constraint Generation/ Resolution *) -(* *) -(***********************************************************************) - - -(** Make the type a global type *) -let set_global (t : tau) (b : bool) : unit = - let set_global_down t = - match find t with - Var v -> v.v_global <- true - | Ref r -> set_global_label r.rl true - | Fun f -> set_global_label f.fl true - | _ -> () - in - if !debug && b then Printf.printf "Set global: %s\n" (string_of_tau t); - assert ((not (get_global t)) || b); - if b then iter_tau set_global_down t; - match find t with - Var v -> v.v_global <- b - | Ref r -> r.r_global <- b - | Pair p -> p.p_global <- b - | Fun f -> f.f_global <- b - - -let rec unify_int (t, t' : tau * tau) : unit = - if equal_tau t t' then () - else - let ti, ti' = find t, find t' in - U.unify combine (t, t'); - match ti, ti' with - Var v, Var v' -> - set_global t' (v.v_global || get_global t'); - merge_vholes (v, v'); - merge_vlbs (v, v'); - merge_vubs (v, v') - | Var v, _ -> - set_global t' (v.v_global || get_global t'); - trigger_vhole v t'; - notify_vlbs t v; - notify_vubs t v - | _, Var v -> - set_global t (v.v_global || get_global t); - trigger_vhole v t; - notify_vlbs t' v; - notify_vubs t' v - | Ref r, Ref r' -> - set_global t (r.r_global || r'.r_global); - unify_ref (r, r') - | Fun f, Fun f' -> - set_global t (f.f_global || f'.f_global); - unify_fun (f, f') - | Pair p, Pair p' -> () - | _ -> raise Inconsistent -and notify_vlbs (t : tau) (vi : vinfo) : unit = - let notify p bounds = - List.iter - (fun b -> - add_constraint (Unification (b.info,copy_toplevel t)); - add_constraint (Leq (b.info, (b.index, p), t))) - bounds - in - notify Sub (B.elements vi.v_mlbs); - notify Pos (B.elements vi.v_plbs); - notify Neg (B.elements vi.v_nlbs) -and notify_vubs (t : tau) (vi : vinfo) : unit = - let notify p bounds = - List.iter - (fun b -> - add_constraint (Unification (b.info,copy_toplevel t)); - add_constraint (Leq (t, (b.index, p), b.info))) - bounds - in - notify Sub (B.elements vi.v_mubs); - notify Pos (B.elements vi.v_pubs); - notify Neg (B.elements vi.v_nubs) -and unify_ref (ri,ri' : rinfo * rinfo) : unit = - add_constraint (Unification (ri.points_to, ri'.points_to)) -and unify_fun (fi, fi' : finfo * finfo) : unit = - let rec union_args = function - _, [] -> false - | [], _ -> true - | h :: t, h' :: t' -> - add_constraint (Unification (h, h')); - union_args(t, t') - in - unify_label(fi.fl, fi'.fl); - add_constraint (Unification (fi.ret, fi'.ret)); - if union_args (fi.args, fi'.args) then fi.args <- fi'.args; -and unify_label (l, l' : label * label) : unit = - let pick_name (li, li' : lblinfo * lblinfo) = - if String.length li.l_name > 1 && String.sub (li.l_name) 0 2 = "l_" then - li.l_name <- li'.l_name - else () - in - let combine_label (li, li' : lblinfo *lblinfo) : lblinfo = - let rm_self b = not (li.l_stamp = get_label_stamp b.info) - in - pick_name (li, li'); - li.l_global <- li.l_global || li'.l_global; - li.aliases <- C.union li.aliases li'.aliases; - li.p_ubounds <- B.union li.p_ubounds li'.p_ubounds; - li.p_lbounds <- B.union li.p_lbounds li'.p_lbounds; - li.n_ubounds <- B.union li.n_ubounds li'.n_ubounds; - li.n_lbounds <- B.union li.n_lbounds li'.n_lbounds; - li.m_ubounds <- B.union li.m_ubounds (B.filter rm_self li'.m_ubounds); - li.m_lbounds <- B.union li.m_lbounds (B.filter rm_self li'.m_lbounds); - li.m_upath <- P.union li.m_upath li'.m_upath; - li.m_lpath<- P.union li.m_lpath li'.m_lpath; - li.n_upath <- P.union li.n_upath li'.n_upath; - li.n_lpath <- P.union li.n_lpath li'.n_lpath; - li.p_upath <- P.union li.p_upath li'.p_upath; - li.p_lpath <- P.union li.p_lpath li'.p_lpath; - li.l_seeded <- li.l_seeded || li'.l_seeded; - li.l_ret <- li.l_ret || li'.l_ret; - li.l_param <- li.l_param || li'.l_param; - li - in - if !debug_constraints then - Printf.printf "%s == %s\n" (string_of_label l) (string_of_label l'); - U.unify combine_label (l, l') -and merge_vholes (vi, vi' : vinfo * vinfo) : unit = - H.iter - (fun i -> fun _ -> H.replace vi'.v_hole i ()) - vi.v_hole -and merge_vlbs (vi, vi' : vinfo * vinfo) : unit = - vi'.v_mlbs <- B.union vi.v_mlbs vi'.v_mlbs; - vi'.v_plbs <- B.union vi.v_plbs vi'.v_plbs; - vi'.v_nlbs <- B.union vi.v_nlbs vi'.v_nlbs -and merge_vubs (vi, vi' : vinfo * vinfo) : unit = - vi'.v_mubs <- B.union vi.v_mubs vi'.v_mubs; - vi'.v_pubs <- B.union vi.v_pubs vi'.v_pubs; - vi'.v_nubs <- B.union vi.v_nubs vi'.v_nubs -and trigger_vhole (vi : vinfo) (t : tau) = - let add_self_loops (t : tau) : unit = - match find t with - Var v -> - H.iter - (fun i -> fun _ -> H.replace v.v_hole i ()) - vi.v_hole - | Ref r -> - H.iter - (fun i -> fun _ -> - leq_label (r.rl, (i, Pos), r.rl); - leq_label (r.rl, (i, Neg), r.rl)) - vi.v_hole - | Fun f -> - H.iter - (fun i -> fun _ -> - leq_label (f.fl, (i, Pos), f.fl); - leq_label (f.fl, (i, Neg), f.fl)) - vi.v_hole - | _ -> () - in - iter_tau add_self_loops t -(** Pick the representative info for two tinfo's. This function prefers the - first argument when both arguments are the same structure, but when - one type is a structure and the other is a var, it picks the structure. - All other actions (e.g., updating the info) is done in unify_int *) -and combine (ti, ti' : tinfo * tinfo) : tinfo = - match ti, ti' with - Var _, _ -> ti' - | _, _ -> ti -and leq_int (t, (i, p), t') : unit = - if equal_tau t t' then () - else - let ti, ti' = find t, find t' in - match ti, ti' with - Var v, Var v' -> - begin - match p with - Pos -> - v.v_pubs <- B.add (make_tau_bound (i, t')) v.v_pubs; - v'.v_plbs <- B.add (make_tau_bound (i, t)) v'.v_plbs - | Neg -> - v.v_nubs <- B.add (make_tau_bound (i, t')) v.v_nubs; - v'.v_nlbs <- B.add (make_tau_bound (i, t)) v'.v_nlbs - | Sub -> - v.v_mubs <- B.add (make_tau_bound (i, t')) v.v_mubs; - v'.v_mlbs <- B.add (make_tau_bound (i, t)) v'.v_mlbs - end - | Var v, _ -> - add_constraint (Unification (t, copy_toplevel t')); - add_constraint (Leq (t, (i, p), t')) - | _, Var v -> - add_constraint (Unification (t', copy_toplevel t)); - add_constraint (Leq (t, (i, p), t')) - | Ref r, Ref r' -> leq_ref (r, (i, p), r') - | Fun f, Fun f' -> add_constraint (Unification (t, t')) - | Pair pr, Pair pr' -> - add_constraint (Leq (pr.ptr, (i, p), pr'.ptr)); - add_constraint (Leq (pr.lam, (i, p), pr'.lam)) - | _ -> raise Inconsistent -and leq_ref (ri, (i, p), ri') : unit = - let add_self_loops (t : tau) : unit = - match find t with - Var v -> H.replace v.v_hole i () - | Ref r -> - leq_label (r.rl, (i, Pos), r.rl); - leq_label (r.rl, (i, Neg), r.rl) - | Fun f -> - leq_label (f.fl, (i, Pos), f.fl); - leq_label (f.fl, (i, Neg), f.fl) - | _ -> () - in - iter_tau add_self_loops ri.points_to; - add_constraint (Unification (ri.points_to, ri'.points_to)); - leq_label(ri.rl, (i, p), ri'.rl) -and leq_label (l,(i, p), l') : unit = - if !debug_constraints then - Printf.printf - "%s <={%d,%s} %s\n" - (string_of_label l) i (string_of_polarity p) (string_of_label l'); - let li, li' = find l, find l' in - match p with - Pos -> - li.l_ret <- true; - li.p_ubounds <- B.add (make_bound (i, l')) li.p_ubounds; - li'.p_lbounds <- B.add (make_bound (i, l)) li'.p_lbounds - | Neg -> - li'.l_param <- true; - li.n_ubounds <- B.add (make_bound (i, l')) li.n_ubounds; - li'.n_lbounds <- B.add (make_bound (i, l)) li'.n_lbounds - | Sub -> - if U.equal (l, l') then () - else - begin - li.m_ubounds <- B.add (make_bound(0, l')) li.m_ubounds; - li'.m_lbounds <- B.add (make_bound(0, l)) li'.m_lbounds - end -and add_constraint_int (c : tconstraint) (toplev : bool) = - if !debug_constraints && toplev then - begin - Printf.printf "%d:>" !toplev_count; - print_constraint c; - incr toplev_count - end - else - if !debug_constraints then print_constraint c else (); - begin - match c with - Unification _ -> Q.add c eq_worklist - | Leq _ -> Q.add c leq_worklist - end; - solve_constraints () -and add_constraint (c : tconstraint) = - add_constraint_int c false -and add_toplev_constraint (c : tconstraint) = - if !print_constraints && not !debug_constraints then - begin - Printf.printf "%d:>" !toplev_count; - incr toplev_count; - print_constraint c - end - else (); - add_constraint_int c true -and fetch_constraint () : tconstraint option = - try Some (Q.take eq_worklist) - with Q.Empty -> (try Some (Q.take leq_worklist) - with Q.Empty -> None) -(** The main solver loop. *) -and solve_constraints () : unit = - match fetch_constraint () with - Some c -> - begin - match c with - Unification (t, t') -> unify_int (t, t') - | Leq (t, (i, p), t') -> - if !no_sub then unify_int (t, t') - else - if !analyze_mono then leq_int (t, (0, Sub), t') - else leq_int (t, (i, p), t') - end; - solve_constraints () - | None -> () - - -(***********************************************************************) -(* *) -(* Interface Functions *) -(* *) -(***********************************************************************) - -(** Return the contents of the lvalue. *) -let rvalue (lv : lvalue) : tau = - lv.contents - -(** Dereference the rvalue. If it does not have enough structure to support - the operation, then the correct structure is added via new unification - constraints. *) -let rec deref (t : tau) : lvalue = - match U.deref t with - Pair p -> - begin - match U.deref p.ptr with - Var _ -> - let is_global = global_tau p.ptr in - let points_to = fresh_var is_global in - let l = fresh_label is_global in - let r = make_ref (l, points_to) - in - add_toplev_constraint (Unification (p.ptr, r)); - make_lval (l, points_to) - | Ref r -> make_lval (r.rl, r.points_to) - | _ -> raise WellFormed - end - | Var v -> - let is_global = global_tau t in - add_toplev_constraint - (Unification (t, make_pair (fresh_var is_global, - fresh_var is_global))); - deref t - | _ -> raise WellFormed - -(** Form the union of [t] and [t'], if it doesn't exist already. *) -let join (t : tau) (t' : tau) : tau = - try H.find join_cache (get_stamp t, get_stamp t') - with Not_found -> - let t'' = fresh_var false in - add_toplev_constraint (Leq (t, (0, Sub), t'')); - add_toplev_constraint (Leq (t', (0, Sub), t'')); - H.add join_cache (get_stamp t, get_stamp t') t''; - t'' - -(** Form the union of a list [tl], expected to be the initializers of some - structure or array type. *) -let join_inits (tl : tau list) : tau = - let t' = fresh_var false in - List.iter - (fun t -> add_toplev_constraint (Leq (t, (0, Sub), t'))) - tl; - t' - -(** Take the address of an lvalue. Does not add constraints. *) -let address (lv : lvalue) : tau = - make_pair (make_ref (lv.l, lv.contents), fresh_var false) - -(** For this version of golf, instantiation is handled at [apply] *) -let instantiate (lv : lvalue) (i : int) : lvalue = - lv - -(** Constraint generated from assigning [t] to [lv]. *) -let assign (lv : lvalue) (t : tau) : unit = - add_toplev_constraint (Leq (t, (0, Sub), lv.contents)) - -let assign_ret (i : int) (lv : lvalue) (t : tau) : unit = - add_toplev_constraint (Leq (t, (i, Pos), lv.contents)) - -(** Project out the first (ref) component or a pair. If the argument [t] has - no discovered structure, raise NoContents. *) -let proj_ref (t : tau) : tau = - match U.deref t with - Pair p -> p.ptr - | Var v -> raise NoContents - | _ -> raise WellFormed - -(* Project out the second (fun) component of a pair. If the argument [t] has - no discovered structure, create it on the fly by adding constraints. *) -let proj_fun (t : tau) : tau = - match U.deref t with - Pair p -> p.lam - | Var v -> - let p, f = fresh_var false, fresh_var false in - add_toplev_constraint (Unification (t, make_pair(p, f))); - f - | _ -> raise WellFormed - -let get_args (t : tau) : tau list = - match U.deref t with - Fun f -> f.args - | _ -> raise WellFormed - -let get_finfo (t : tau) : finfo = - match U.deref t with - Fun f -> f - | _ -> raise WellFormed - -(** Function type [t] is applied to the arguments [actuals]. Unifies the - actuals with the formals of [t]. If no functions have been discovered for - [t] yet, create a fresh one and unify it with t. The result is the return - value of the function plus the index of this application site. *) -let apply (t : tau) (al : tau list) : (tau * int) = - let i = fresh_appsite () in - let f = proj_fun t in - let actuals = ref al in - let fi,ret = - match U.deref f with - Fun fi -> fi, fi.ret - | Var v -> - let new_l, new_ret, new_args = - fresh_label false, fresh_var false, - List.map (function _ -> fresh_var false) !actuals - in - let new_fun = make_fun (new_l, new_args, new_ret) in - add_toplev_constraint (Unification (new_fun, f)); - (get_finfo new_fun, new_ret) - | _ -> raise WellFormed - in - pad_args2 (fi, actuals); - List.iter2 - (fun actual -> fun formal -> - add_toplev_constraint (Leq (actual,(i, Neg), formal))) - !actuals fi.args; - (ret, i) - -(** Create a new function type with name [name], list of formal arguments - [formals], and return value [ret]. Adds no constraints. *) -let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = - let f = make_fun (make_label false name None, - List.map (fun x -> rvalue x) formals, - ret) - in - make_pair (fresh_var false, f) - -(** Create an lvalue. If [is_global] is true, the lvalue will be treated - monomorphically. *) -let make_lvalue (is_global : bool) (name : string) (vio : Cil.varinfo option) : lvalue = - if !debug && is_global then - Printf.printf "Making global lvalue : %s\n" name - else (); - make_lval (make_label is_global name vio, make_var is_global name) - -(** Create a fresh non-global named variable. *) -let make_fresh (name : string) : tau = - make_var false name - -(** The default type for constants. *) -let bottom () : tau = - make_var false "bottom" - -(** Unify the result of a function with its return value. *) -let return (t : tau) (t' : tau) = - add_toplev_constraint (Leq (t', (0, Sub), t)) - -(***********************************************************************) -(* *) -(* Query/Extract Solutions *) -(* *) -(***********************************************************************) - -let make_summary = leq_label - -let path_signature k l l' b : int list = - let ksig = - match k with - Positive -> 1 - | Negative -> 2 - | _ -> 3 - in - [ksig; - get_label_stamp l; - get_label_stamp l'; - if b then 1 else 0] - -let make_path (k, l, l', b) = - let psig = path_signature k l l' b in - if PH.mem path_hash psig then () - else - let new_path = {kind = k; head = l; tail = l'; reached_global = b} - and li, li' = find l, find l' in - PH.add path_hash psig new_path; - Q.add new_path path_worklist; - begin - match k with - Positive -> - li.p_upath <- P.add new_path li.p_upath; - li'.p_lpath <- P.add new_path li'.p_lpath - | Negative -> - li.n_upath <- P.add new_path li.n_upath; - li'.n_lpath <- P.add new_path li'.n_lpath - | _ -> - li.m_upath <- P.add new_path li.m_upath; - li'.m_lpath <- P.add new_path li'.m_lpath - end; - if !debug then - begin - print_string "Discovered path : "; - print_path new_path; - print_newline () - end - -let backwards_tabulate (l : label) : unit = - let rec loop () = - let rule1 p = - if !debug then print_endline "rule1"; - B.iter - (fun lb -> - make_path (Match, lb.info, p.tail, - p.reached_global || is_global_label p.head)) - (find p.head).m_lbounds - and rule2 p = - if !debug then print_endline "rule2"; - B.iter - (fun lb -> - make_path (Negative, lb.info, p.tail, - p.reached_global || is_global_label p.head)) - (find p.head).n_lbounds - and rule2m p = - if !debug then print_endline "rule2m"; - B.iter - (fun lb -> - make_path (Match, lb.info, p.tail, - p.reached_global || is_global_label p.head)) - (find p.head).n_lbounds - and rule3 p = - if !debug then print_endline "rule3"; - B.iter - (fun lb -> - make_path (Positive, lb.info, p.tail, - p.reached_global || is_global_label p.head)) - (find p.head).p_lbounds - and rule4 p = - if !debug then print_endline "rule4"; - B.iter - (fun lb -> - make_path(Negative, lb.info, p.tail, - p.reached_global || is_global_label p.head)) - (find p.head).m_lbounds - and rule5 p = - if !debug then print_endline "rule5"; - B.iter - (fun lb -> - make_path (Positive, lb.info, p.tail, - p.reached_global || is_global_label p.head)) - (find p.head).m_lbounds - and rule6 p = - if !debug then print_endline "rule6"; - B.iter - (fun lb -> - if is_seeded_label lb.info then () - else - begin - (find lb.info).l_seeded <- true; (* set seeded *) - make_path (Seed, lb.info, lb.info, - is_global_label lb.info) - end) - (find p.head).p_lbounds - and rule7 p = - if !debug then print_endline "rule7"; - if not (is_ret_label p.tail && is_param_label p.head) then () - else - B.iter - (fun lb -> - B.iter - (fun ub -> - if lb.index = ub.index then - begin - if !debug then - Printf.printf "New summary : %s %s\n" - (string_of_label lb.info) - (string_of_label ub.info); - make_summary (lb.info, (0, Sub), ub.info); - (* rules 1, 4, and 5 *) - P.iter - (fun ubp -> (* rule 1 *) - make_path (Match, lb.info, ubp.tail, - ubp.reached_global)) - (find ub.info).m_upath; - P.iter - (fun ubp -> (* rule 4 *) - make_path (Negative, lb.info, ubp.tail, - ubp.reached_global)) - (find ub.info).n_upath; - P.iter - (fun ubp -> (* rule 5 *) - make_path (Positive, lb.info, ubp.tail, - ubp.reached_global)) - (find ub.info).p_upath - end) - (find p.tail).p_ubounds) - (find p.head).n_lbounds - in - let matched_backward_rules p = - rule1 p; - if p.reached_global then rule2m p else rule2 p; - rule3 p; - rule6 p; - rule7 p - and negative_backward_rules p = - rule2 p; - rule3 p; - rule4 p; - rule6 p; - rule7 p - and positive_backward_rules p = - rule3 p; - rule5 p; - rule6 p; - rule7 p - in (* loop *) - if Q.is_empty path_worklist then () - else - let p = Q.take path_worklist in - if !debug then - begin - print_string "Processing path: "; - print_path p; - print_newline () - end; - begin - match p.kind with - Positive -> - if is_global_label p.tail then matched_backward_rules p - else positive_backward_rules p - | Negative -> negative_backward_rules p - | _ -> matched_backward_rules p - end; - loop () - in (* backwards_tabulate *) - if !debug then - begin - Printf.printf "Tabulating for %s..." (string_of_label l); - if is_global_label l then print_string "(global)"; - print_newline () - end; - make_path (Seed, l, l, is_global_label l); - loop () - -let collect_ptsets (l : label) : constantset = (* todo -- cache aliases *) - let li = find l - and collect init s = - P.fold (fun x a -> C.union a (find x.head).aliases) s init - in - backwards_tabulate l; - collect (collect (collect li.aliases li.m_lpath) li.n_lpath) li.p_lpath - -let extract_ptlabel (lv : lvalue) : label option = - try - match find (proj_ref lv.contents) with - Var v -> None - | Ref r -> Some r.rl; - | _ -> raise WellFormed - with NoContents -> None - -let points_to_aux (t : tau) : constant list = - try - match find (proj_ref t) with - Var v -> [] - | Ref r -> C.elements (collect_ptsets r.rl) - | _ -> raise WellFormed - with NoContents -> [] - -let points_to_names (lv : lvalue) : string list = - List.map (fun (_, str, _) -> str) (points_to_aux lv.contents) - -let points_to (lv : lvalue) : Cil.varinfo list = - let rec get_vinfos l : Cil.varinfo list = match l with - | (_, _, h) :: t -> h :: get_vinfos t - | [] -> [] - in - get_vinfos (points_to_aux lv.contents) - -let epoints_to (t : tau) : Cil.varinfo list = - let rec get_vinfos l : Cil.varinfo list = match l with - | (_, _, h) :: t -> h :: get_vinfos t - | [] -> [] - in - get_vinfos (points_to_aux t) - -let smart_alias_query (l : label) (l' : label) : bool = - (* Set of dead configurations *) - let dead_configs : config_map = CH.create 16 in - (* the set of discovered configurations *) - let discovered : config_map = CH.create 16 in - let rec filter_match (i : int) = - B.filter (fun (b : lblinfo bound) -> i = b.index) - in - let rec simulate c l l' = - let config = (c, get_label_stamp l, get_label_stamp l') in - if U.equal (l, l') then - begin - if !debug then - Printf.printf - "%s and %s are aliased\n" - (string_of_label l) - (string_of_label l'); - raise APFound - end - else if CH.mem discovered config then () - else - begin - if !debug_aliases then - Printf.printf - "Exploring configuration %s\n" - (string_of_configuration config); - CH.add discovered config (); - B.iter - (fun lb -> simulate c lb.info l') - (get_bounds Sub false l); (* epsilon closure of l *) - B.iter - (fun lb -> simulate c l lb.info) - (get_bounds Sub false l'); (* epsilon closure of l' *) - B.iter - (fun lb -> - let matching = - filter_match lb.index (get_bounds Pos false l') - in - B.iter - (fun b -> simulate Closed lb.info b.info) - matching; - if is_global_label l' then (* positive self-loops on l' *) - simulate Closed lb.info l') - (get_bounds Pos false l); (* positive transitions on l *) - if is_global_label l then - B.iter - (fun lb -> simulate Closed l lb.info) - (get_bounds Pos false l'); (* positive self-loops on l *) - begin - match c with (* negative transitions on l, only if Open *) - Open -> - B.iter - (fun lb -> - let matching = - filter_match lb.index (get_bounds Neg false l') - in - B.iter - (fun b -> simulate Open lb.info b.info) - matching ; - if is_global_label l' then (* neg self-loops on l' *) - simulate Open lb.info l') - (get_bounds Neg false l); - if is_global_label l then - B.iter - (fun lb -> simulate Open l lb.info) - (get_bounds Neg false l') (* negative self-loops on l *) - | _ -> () - end; - (* if we got this far, then the configuration was not used *) - CH.add dead_configs config (); - end - in - try - begin - if H.mem cached_aliases (get_label_stamp l, get_label_stamp l') then - true - else - begin - simulate Open l l'; - if !debug then - Printf.printf - "%s and %s are NOT aliased\n" - (string_of_label l) - (string_of_label l'); - false - end - end - with APFound -> - CH.iter - (fun config -> fun _ -> - if not (CH.mem dead_configs config) then - H.add - cached_aliases - (get_label_stamp l, get_label_stamp l') - ()) - discovered; - true - -(** todo : uses naive alias query for now *) -let may_alias (t1 : tau) (t2 : tau) : bool = - try - let l1 = - match find (proj_ref t1) with - Ref r -> r.rl - | Var v -> raise NoContents - | _ -> raise WellFormed - and l2 = - match find (proj_ref t2) with - Ref r -> r.rl - | Var v -> raise NoContents - | _ -> raise WellFormed - in - not (C.is_empty (C.inter (collect_ptsets l1) (collect_ptsets l2))) - with NoContents -> false - -let alias_query (b : bool) (lvl : lvalue list) : int * int = - let naive_count = ref 0 in - let smart_count = ref 0 in - let lbls = List.map extract_ptlabel lvl in (* label option list *) - let ptsets = - List.map - (function - Some l -> collect_ptsets l - | None -> C.empty) - lbls in - let record_alias s lo s' lo' = - match lo, lo' with - Some l, Some l' -> - if !debug_aliases then - Printf.printf - "Checking whether %s and %s are aliased...\n" - (string_of_label l) - (string_of_label l'); - if C.is_empty (C.inter s s') then () - else - begin - incr naive_count; - if !smart_aliases && smart_alias_query l l' then - incr smart_count - end - | _ -> () - in - let rec check_alias sets labels = - match sets,labels with - s :: st, l :: lt -> - List.iter2 (record_alias s l) ptsets lbls; - check_alias st lt - | [], [] -> () - | _ -> die "check_alias" - in - check_alias ptsets lbls; - (!naive_count, !smart_count) - -let alias_frequency (lvl : (lvalue * bool) list) : int * int = - let extract_lbl (lv, b : lvalue * bool) = (lv.l, b) in - let naive_count = ref 0 in - let smart_count = ref 0 in - let lbls = List.map extract_lbl lvl in - let ptsets = - List.map - (fun (lbl, b) -> - if b then (find lbl).loc (* symbol access *) - else collect_ptsets lbl) - lbls in - let record_alias s (l, b) s' (l', b') = - if !debug_aliases then - Printf.printf - "Checking whether %s and %s are aliased...\n" - (string_of_label l) - (string_of_label l'); - if C.is_empty (C.inter s s') then () - else - begin - if !debug_aliases then - Printf.printf - "%s and %s are aliased naively...\n" - (string_of_label l) - (string_of_label l'); - incr naive_count; - if !smart_aliases then - if b || b' || smart_alias_query l l' then incr smart_count - else - Printf.printf - "%s and %s are not aliased by smart queries...\n" - (string_of_label l) - (string_of_label l'); - end - in - let rec check_alias sets labels = - match sets, labels with - s :: st, l :: lt -> - List.iter2 (record_alias s l) ptsets lbls; - check_alias st lt - | [], [] -> () - | _ -> die "check_alias" - in - check_alias ptsets lbls; - (!naive_count, !smart_count) - - -(** an interface for extracting abstract locations from this analysis *) - -type absloc = label - -let absloc_of_lvalue (l : lvalue) : absloc = l.l -let absloc_eq (a1, a2) = smart_alias_query a1 a2 -let absloc_print_name = ref true -let d_absloc () (p : absloc) = - let a = find p in - if !absloc_print_name then Pretty.dprintf "%s" a.l_name - else Pretty.dprintf "%d" a.l_stamp - -let phonyAddrOf (lv : lvalue) : lvalue = - make_lval (fresh_label true, address lv) - -(* transitive closure of points to, starting from l *) -let rec tauPointsTo (l : tau) : absloc list = - match find l with - Var _ -> [] - | Ref r -> r.rl :: tauPointsTo r.points_to - | _ -> [] - -let rec absloc_points_to (l : lvalue) : absloc list = - tauPointsTo l.contents - - -(** The following definitions are only introduced for the - compatability with Olf. *) - -exception UnknownLocation - -let finished_constraints () = () -let apply_undefined (_ : tau list) = (fresh_var true, 0) -let assign_undefined (_ : lvalue) = () - -let absloc_epoints_to = tauPointsTo diff --git a/cil/src/ext/pta/golf.mli b/cil/src/ext/pta/golf.mli deleted file mode 100644 index 569855c..0000000 --- a/cil/src/ext/pta/golf.mli +++ /dev/null @@ -1,83 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -type lvalue -type tau -type absloc - -(* only for compatability with Olf *) -exception UnknownLocation - -val debug : bool ref -val debug_constraints : bool ref -val debug_aliases : bool ref -val smart_aliases : bool ref -val finished_constraints : unit -> unit (* only for compatability with Olf *) -val print_constraints : bool ref -val no_flow : bool ref -val no_sub : bool ref -val analyze_mono : bool ref -val solve_constraints : unit -> unit -val rvalue : lvalue -> tau -val deref : tau -> lvalue -val join : tau -> tau -> tau -val join_inits : tau list -> tau -val address : lvalue -> tau -val instantiate : lvalue -> int -> lvalue -val assign : lvalue -> tau -> unit -val assign_ret : int -> lvalue -> tau -> unit -val apply : tau -> tau list -> (tau * int) -val apply_undefined : tau list -> (tau * int) (* only for compatability with Olf *) -val assign_undefined : lvalue -> unit (* only for compatability with Olf *) -val make_function : string -> lvalue list -> tau -> tau -val make_lvalue : bool -> string -> (Cil.varinfo option) -> lvalue -val bottom : unit -> tau -val return : tau -> tau -> unit -val make_fresh : string -> tau -val points_to_names : lvalue -> string list -val points_to : lvalue -> Cil.varinfo list -val epoints_to : tau -> Cil.varinfo list -val string_of_lvalue : lvalue -> string -val global_lvalue : lvalue -> bool -val alias_query : bool -> lvalue list -> int * int -val alias_frequency : (lvalue * bool) list -> int * int - -val may_alias : tau -> tau -> bool - -val absloc_points_to : lvalue -> absloc list -val absloc_epoints_to : tau -> absloc list -val absloc_of_lvalue : lvalue -> absloc -val absloc_eq : (absloc * absloc) -> bool -val d_absloc : unit -> absloc -> Pretty.doc -val phonyAddrOf : lvalue -> lvalue diff --git a/cil/src/ext/pta/olf.ml b/cil/src/ext/pta/olf.ml deleted file mode 100644 index 0d77002..0000000 --- a/cil/src/ext/pta/olf.ml +++ /dev/null @@ -1,1108 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(***********************************************************************) -(* *) -(* Exceptions *) -(* *) -(***********************************************************************) - -exception Inconsistent (* raised if constraint system is inconsistent *) -exception WellFormed (* raised if types are not well-formed *) -exception NoContents -exception APFound (* raised if an alias pair is found, a control - flow exception *) -exception ReachedTop (* raised if top (from an undefined function) - flows to a c_absloc during the flow step *) -exception UnknownLocation - -let solve_constraints () = () (* only for compatability with Golf *) - -open Cil - -module U = Uref -module S = Setp -module H = Hashtbl -module Q = Queue - -(** Generic bounds *) -type 'a bound = {info : 'a U.uref} - -module Bound = -struct - type 'a t = 'a bound - let compare (x : 'a t) (y : 'a t) = - Pervasives.compare (U.deref x.info) (U.deref y.info) -end - -module B = S.Make (Bound) - -type 'a boundset = 'a B.t - -(** Abslocs, which identify elements in points-to sets *) -(** jk : I'd prefer to make this an 'a absloc and specialize it to - varinfo for use with the Cil frontend, but for now, this will do *) -type absloc = int * string * Cil.varinfo option - -module Absloc = -struct - type t = absloc - let compare (xid, _, _) (yid, _, _) = xid - yid -end - -module C = Set.Make (Absloc) - -(** Sets of abslocs. Set union is used when two c_abslocs containing - absloc sets are unified *) -type abslocset = C.t - -let d_absloc () (a: absloc) : Pretty.doc = - let i,s,_ = a in - Pretty.dprintf "<%d, %s>" i s - -type c_abslocinfo = { - mutable l_name: string; (** name of the location *) - loc : absloc; - l_stamp : int; - mutable l_top : bool; - mutable aliases : abslocset; - mutable lbounds : c_abslocinfo boundset; - mutable ubounds : c_abslocinfo boundset; - mutable flow_computed : bool -} -and c_absloc = c_abslocinfo U.uref - -(** The type of lvalues. *) -type lvalue = { - l: c_absloc; - contents: tau -} -and vinfo = { - v_stamp : int; - v_name : string; - mutable v_top : bool; - mutable v_lbounds : tinfo boundset; - mutable v_ubounds : tinfo boundset -} -and rinfo = { - r_stamp : int; - rl : c_absloc; - points_to : tau -} -and finfo = { - f_stamp : int; - fl : c_absloc; - ret : tau; - mutable args : tau list -} -and pinfo = { - p_stamp : int; - ptr : tau; - lam : tau -} -and tinfo = - Var of vinfo - | Ref of rinfo - | Fun of finfo - | Pair of pinfo -and tau = tinfo U.uref - -type tconstraint = - Unification of tau * tau - | Leq of tau * tau - -(** Association lists, used for printing recursive types. The first - element is a type that has been visited. The second element is the - string representation of that type (so far). If the string option is - set, then this type occurs within itself, and is associated with the - recursive var name stored in the option. When walking a type, add it - to an association list. - - Example: suppose we have the constraint 'a = ref('a). The type is - unified via cyclic unification, and would loop infinitely if we - attempted to print it. What we want to do is print the type u - rv. ref(rv). This is accomplished in the following manner: - - -- ref('a) is visited. It is not in the association list, so it is - added and the string "ref(" is stored in the second element. We - recurse to print the first argument of the constructor. - - -- In the recursive call, we see that 'a (or ref('a)) is already - in the association list, so the type is recursive. We check the - string option, which is None, meaning that this is the first - recurrence of the type. We create a new recursive variable, rv and - set the string option to 'rv. Next, we prepend u rv. to the string - representation we have seen before, "ref(", and return "rv" as the - string representation of this type. - - -- The string so far is "u rv.ref(". The recursive call returns, - and we complete the type by printing the result of the call, "rv", - and ")" - - In a type where the recursive variable appears twice, e.g. 'a = - pair('a,'a), the second time we hit 'a, the string option will be - set, so we know to reuse the same recursive variable name. -*) -type association = tau * string ref * string option ref - -(** The current state of the solver engine either adding more - constraints, or finished adding constraints and querying graph *) -type state = - AddingConstraints - | FinishedConstraints - -(***********************************************************************) -(* *) -(* Global Variables *) -(* *) -(***********************************************************************) - -(** A count of the constraints introduced from the AST. Used for - debugging. *) -let toplev_count = ref 0 - -let solver_state : state ref = ref AddingConstraints - -(** Print the instantiations constraints. *) -let print_constraints : bool ref = ref false - -(** If true, print all constraints (including induced) and show - additional debug output. *) -let debug = ref false - -(** Just debug all the constraints (including induced) *) -let debug_constraints = ref false - -(** Debug the flow step *) -let debug_flow_step = ref false - -(** Compatibility with GOLF *) -let debug_aliases = ref false -let smart_aliases = ref false -let no_flow = ref false -let analyze_mono = ref false - -(** If true, disable subtyping (unification at all levels) *) -let no_sub = ref false - -(** A list of equality constraints. *) -let eq_worklist : tconstraint Q.t = Q.create () - -(** A list of leq constraints. *) -let leq_worklist : tconstraint Q.t = Q.create () - -(** A hashtable containing stamp pairs of c_abslocs that must be aliased. *) -let cached_aliases : (int * int, unit) H.t = H.create 64 - -(** A hashtable mapping pairs of tau's to their join node. *) -let join_cache : (int * int, tau) H.t = H.create 64 - -(** *) -let label_prefix = "l_" - - -(***********************************************************************) -(* *) -(* Utility Functions *) -(* *) -(***********************************************************************) - -let starts_with s p = - let n = String.length p in - if String.length s < n then false - else String.sub s 0 n = p - - -let die s = - Printf.printf "*******\nAssertion failed: %s\n*******\n" s; - assert false - -let insist b s = - if not b then die s else () - - -let can_add_constraints () = - !solver_state = AddingConstraints - -let can_query_graph () = - !solver_state = FinishedConstraints - -let finished_constraints () = - insist (!solver_state = AddingConstraints) "inconsistent states"; - solver_state := FinishedConstraints - -let find = U.deref - -(** return the prefix of the list up to and including the first - element satisfying p. if no element satisfies p, return the empty - list *) -let rec keep_until p l = - match l with - [] -> [] - | x :: xs -> if p x then [x] else x :: keep_until p xs - - -(** Generate a unique integer. *) -let fresh_index : (unit -> int) = - let counter = ref 0 in - fun () -> - incr counter; - !counter - -let fresh_stamp : (unit -> int) = - let stamp = ref 0 in - fun () -> - incr stamp; - !stamp - -(** Return a unique integer representation of a tau *) -let get_stamp (t : tau) : int = - match find t with - Var v -> v.v_stamp - | Ref r -> r.r_stamp - | Pair p -> p.p_stamp - | Fun f -> f.f_stamp - -(** Consistency checks for inferred types *) -let pair_or_var (t : tau) = - match find t with - Pair _ -> true - | Var _ -> true - | _ -> false - -let ref_or_var (t : tau) = - match find t with - Ref _ -> true - | Var _ -> true - | _ -> false - -let fun_or_var (t : tau) = - match find t with - Fun _ -> true - | Var _ -> true - | _ -> false - - -(** Apply [f] structurally down [t]. Guaranteed to terminate, even if [t] - is recursive *) -let iter_tau f t = - let visited : (int, tau) H.t = H.create 4 in - let rec iter_tau' t = - if H.mem visited (get_stamp t) then () else - begin - f t; - H.add visited (get_stamp t) t; - match find t with - Pair p -> - iter_tau' p.ptr; - iter_tau' p.lam - | Fun f -> - List.iter iter_tau' f.args; - iter_tau' f.ret; - | Ref r -> iter_tau' r.points_to - | _ -> () - end - in - iter_tau' t - -let equal_absloc = function - (i, _, _), (i', _, _) -> i = i' - -let equal_c_absloc l l' = - (find l).l_stamp = (find l').l_stamp - -let equal_tau (t : tau) (t' : tau) = - get_stamp t = get_stamp t' - -let top_c_absloc l = - (find l).l_top - -let get_flow_computed l = - (find l).flow_computed - -let set_flow_computed l = - (find l).flow_computed <- true - -let rec top_tau (t : tau) = - match find t with - Pair p -> top_tau p.ptr || top_tau p.lam - | Ref r -> top_c_absloc r.rl - | Fun f -> top_c_absloc f.fl - | Var v -> v.v_top - -let get_c_absloc_stamp (l : c_absloc) : int = - (find l).l_stamp - -let set_top_c_absloc (l : c_absloc) (b: bool) : unit = - (find l).l_top <- b - -let get_aliases (l : c_absloc) = - if top_c_absloc l then raise ReachedTop - else (find l).aliases - -(***********************************************************************) -(* *) -(* Printing Functions *) -(* *) -(***********************************************************************) - -(** Convert a c_absloc to a string, short representation *) -let string_of_c_absloc (l : c_absloc) : string = - "\"" ^ - (find l).l_name ^ - if top_c_absloc l then "(top)" else "" ^ - "\"" - -(** Return true if the element [e] is present in the association list, - according to uref equality *) -let rec assoc_list_mem (e : tau) (l : association list) = - match l with - [] -> None - | (h, s, so) :: t -> - if U.equal (h, e) then Some (s, so) - else assoc_list_mem e t - -(** Given a tau, create a unique recursive variable name. This should - always return the same name for a given tau *) -let fresh_recvar_name (t : tau) : string = - match find t with - Pair p -> "rvp" ^ string_of_int p.p_stamp - | Ref r -> "rvr" ^ string_of_int r.r_stamp - | Fun f -> "rvf" ^ string_of_int f.f_stamp - | _ -> die "fresh_recvar_name" - - -(** Return a string representation of a tau, using association lists. *) -let string_of_tau (t : tau) : string = - let tau_map : association list ref = ref [] in - let rec string_of_tau' t = - match assoc_list_mem t !tau_map with - Some (s, so) -> (* recursive type. see if a var name has been set *) - begin - match !so with - None -> - let rv = fresh_recvar_name t in - s := "u " ^ rv ^ "." ^ !s; - so := Some rv; - rv - | Some rv -> rv - end - | None -> (* type's not recursive. Add it to the assoc list and cont. *) - let s = ref "" - and so : string option ref = ref None in - tau_map := (t, s, so) :: !tau_map; - begin - match find t with - Var v -> s := v.v_name - | Pair p -> - insist (ref_or_var p.ptr) "wellformed"; - insist (fun_or_var p.lam) "wellformed"; - s := "{"; - s := !s ^ string_of_tau' p.ptr; - s := !s ^ ","; - s := !s ^ string_of_tau' p.lam; - s := !s ^ "}" - | Ref r -> - insist (pair_or_var r.points_to) "wellformed"; - s := "ref(|"; - s := !s ^ string_of_c_absloc r.rl; - s := !s ^ "|,"; - s := !s ^ string_of_tau' r.points_to; - s := !s ^ ")" - | Fun f -> - let rec string_of_args = function - [] -> () - | h :: [] -> - insist (pair_or_var h) "wellformed"; - s := !s ^ string_of_tau' h - | h :: t -> - insist (pair_or_var h) "wellformed"; - s := !s ^ string_of_tau' h ^ ","; - string_of_args t - in - insist (pair_or_var f.ret) "wellformed"; - s := "fun(|"; - s := !s ^ string_of_c_absloc f.fl; - s := !s ^ "|,"; - s := !s ^ "<"; - if List.length f.args > 0 then string_of_args f.args - else s := !s ^ "void"; - s := !s ^ ">,"; - s := !s ^ string_of_tau' f.ret; - s := !s ^ ")" - end; - tau_map := List.tl !tau_map; - !s - in - string_of_tau' t - -(** Convert an lvalue to a string *) -let rec string_of_lvalue (lv : lvalue) : string = - let contents = string_of_tau lv.contents - and l = string_of_c_absloc lv.l - in - insist (pair_or_var lv.contents) "inconsistency at string_of_lvalue"; - (* do a consistency check *) - Printf.sprintf "[%s]^(%s)" contents l - -(** Print a list of tau elements, comma separated *) -let rec print_tau_list (l : tau list) : unit = - let rec print_t_strings = function - [] -> () - | h :: [] -> print_endline h - | h :: t -> - print_string h; - print_string ", "; - print_t_strings t - in - print_t_strings (List.map string_of_tau l) - -let print_constraint (c : tconstraint) = - match c with - Unification (t, t') -> - let lhs = string_of_tau t in - let rhs = string_of_tau t' in - Printf.printf "%s == %s\n" lhs rhs - | Leq (t, t') -> - let lhs = string_of_tau t in - let rhs = string_of_tau t' in - Printf.printf "%s <= %s\n" lhs rhs - -(***********************************************************************) -(* *) -(* Type Operations -- these do not create any constraints *) -(* *) -(***********************************************************************) - -(** Create an lvalue with c_absloc [lbl] and tau contents [t]. *) -let make_lval (loc, t : c_absloc * tau) : lvalue = - {l = loc; contents = t} - -let make_c_absloc_int (is_top : bool) (name : string) (vio : Cil.varinfo option) : c_absloc = - let my_absloc = (fresh_index (), name, vio) in - let locc = C.add my_absloc C.empty - in - U.uref { - l_name = name; - l_top = is_top; - l_stamp = fresh_stamp (); - loc = my_absloc; - aliases = locc; - ubounds = B.empty; - lbounds = B.empty; - flow_computed = false - } - -(** Create a new c_absloc with name [name]. Also adds a fresh absloc - with name [name] to this c_absloc's aliases set. *) -let make_c_absloc (is_top : bool) (name : string) (vio : Cil.varinfo option) = - make_c_absloc_int is_top name vio - -let fresh_c_absloc (is_top : bool) : c_absloc = - let index = fresh_index () in - make_c_absloc_int is_top (label_prefix ^ string_of_int index) None - -(** Create a fresh bound (edge in the constraint graph). *) -let make_bound (a : c_absloc) : c_abslocinfo bound = - {info = a} - -let make_tau_bound (t : tau) : tinfo bound = - {info = t} - -(** Create a fresh named variable with name '[name]. *) -let make_var (is_top : bool) (name : string) : tau = - U.uref (Var {v_name = ("'" ^ name); - v_top = is_top; - v_stamp = fresh_index (); - v_lbounds = B.empty; - v_ubounds = B.empty}) - -let fresh_var (is_top : bool) : tau = - make_var is_top ("fi" ^ string_of_int (fresh_index ())) - -(** Create a fresh unnamed variable (name will be 'fi). *) -let fresh_var_i (is_top : bool) : tau = - make_var is_top ("fi" ^ string_of_int (fresh_index ())) - -(** Create a Fun constructor. *) -let make_fun (lbl, a, r : c_absloc * (tau list) * tau) : tau = - U.uref (Fun {fl = lbl; - f_stamp = fresh_index (); - args = a; - ret = r}) - -(** Create a Ref constructor. *) -let make_ref (lbl, pt : c_absloc * tau) : tau = - U.uref (Ref {rl = lbl; - r_stamp = fresh_index (); - points_to = pt}) - -(** Create a Pair constructor. *) -let make_pair (p, f : tau * tau) : tau = - U.uref (Pair {ptr = p; - p_stamp = fresh_index (); - lam = f}) - -(** Copy the toplevel constructor of [t], putting fresh variables in each - argement of the constructor. *) -let copy_toplevel (t : tau) : tau = - match find t with - Pair _ -> make_pair (fresh_var_i false, fresh_var_i false) - | Ref _ -> make_ref (fresh_c_absloc false, fresh_var_i false) - | Fun f -> - make_fun (fresh_c_absloc false, - List.map (fun _ -> fresh_var_i false) f.args, - fresh_var_i false) - | _ -> die "copy_toplevel" - -let has_same_structure (t : tau) (t' : tau) = - match find t, find t' with - Pair _, Pair _ -> true - | Ref _, Ref _ -> true - | Fun _, Fun _ -> true - | Var _, Var _ -> true - | _ -> false - -let pad_args (fi, tlr : finfo * tau list ref) : unit = - let padding = List.length fi.args - List.length !tlr - in - if padding == 0 then () - else - if padding > 0 then - for i = 1 to padding do - tlr := !tlr @ [fresh_var false] - done - else - for i = 1 to -padding do - fi.args <- fi.args @ [fresh_var false] - done - -(***********************************************************************) -(* *) -(* Constraint Generation/ Resolution *) -(* *) -(***********************************************************************) - -let set_top (b : bool) (t : tau) : unit = - let set_top_down t = - match find t with - Var v -> v.v_top <- b - | Ref r -> set_top_c_absloc r.rl b - | Fun f -> set_top_c_absloc f.fl b - | Pair p -> () - in - iter_tau set_top_down t - -let rec unify_int (t, t' : tau * tau) : unit = - if equal_tau t t' then () - else - let ti, ti' = find t, find t' in - U.unify combine (t, t'); - match ti, ti' with - Var v, Var v' -> - set_top (v.v_top || v'.v_top) t'; - merge_v_lbounds (v, v'); - merge_v_ubounds (v, v') - | Var v, _ -> - set_top (v.v_top || top_tau t') t'; - notify_vlbounds t v; - notify_vubounds t v - | _, Var v -> - set_top (v.v_top || top_tau t) t; - notify_vlbounds t' v; - notify_vubounds t' v - | Ref r, Ref r' -> unify_ref (r, r') - | Fun f, Fun f' -> unify_fun (f, f') - | Pair p, Pair p' -> unify_pair (p, p') - | _ -> raise Inconsistent -and notify_vlbounds (t : tau) (vi : vinfo) : unit = - let notify bounds = - List.iter - (fun b -> - add_constraint (Unification (b.info, copy_toplevel t)); - add_constraint (Leq (b.info, t))) - bounds - in - notify (B.elements vi.v_lbounds) -and notify_vubounds (t : tau) (vi : vinfo) : unit = - let notify bounds = - List.iter - (fun b -> - add_constraint (Unification (b.info, copy_toplevel t)); - add_constraint (Leq (t, b.info))) - bounds - in - notify (B.elements vi.v_ubounds) -and unify_ref (ri, ri' : rinfo * rinfo) : unit = - unify_c_abslocs (ri.rl, ri'.rl); - add_constraint (Unification (ri.points_to, ri'.points_to)) -and unify_fun (fi, fi' : finfo * finfo) : unit = - let rec union_args = function - _, [] -> false - | [], _ -> true - | h :: t, h' :: t' -> - add_constraint (Unification (h, h')); - union_args(t, t') - in - unify_c_abslocs (fi.fl, fi'.fl); - add_constraint (Unification (fi.ret, fi'.ret)); - if union_args (fi.args, fi'.args) then fi.args <- fi'.args -and unify_pair (pi, pi' : pinfo * pinfo) : unit = - add_constraint (Unification (pi.ptr, pi'.ptr)); - add_constraint (Unification (pi.lam, pi'.lam)) -and unify_c_abslocs (l, l' : c_absloc * c_absloc) : unit = - let pick_name (li, li' : c_abslocinfo * c_abslocinfo) = - if starts_with li.l_name label_prefix then li.l_name <- li'.l_name - else () in - let combine_c_absloc (li, li' : c_abslocinfo * c_abslocinfo) : c_abslocinfo = - pick_name (li, li'); - li.l_top <- li.l_top || li'.l_top; - li.aliases <- C.union li.aliases li'.aliases; - li.ubounds <- B.union li.ubounds li'.ubounds; - li.lbounds <- B.union li.lbounds li'.lbounds; - li - in - if !debug_constraints then - Printf.printf - "%s == %s\n" - (string_of_c_absloc l) - (string_of_c_absloc l'); - U.unify combine_c_absloc (l, l') -and merge_v_lbounds (vi, vi' : vinfo * vinfo) : unit = - vi'.v_lbounds <- B.union vi.v_lbounds vi'.v_lbounds; -and merge_v_ubounds (vi, vi' : vinfo * vinfo) : unit = - vi'.v_ubounds <- B.union vi.v_ubounds vi'.v_ubounds; -(** Pick the representative info for two tinfo's. This function - prefers the first argument when both arguments are the same - structure, but when one type is a structure and the other is a - var, it picks the structure. All other actions (e.g., updating - the info) is done in unify_int *) -and combine (ti, ti' : tinfo * tinfo) : tinfo = - match ti, ti' with - Var _, _ -> ti' - | _, _ -> ti -and leq_int (t, t') : unit = - if equal_tau t t' then () - else - let ti, ti' = find t, find t' in - match ti, ti' with - Var v, Var v' -> - v.v_ubounds <- B.add (make_tau_bound t') v.v_ubounds; - v'.v_lbounds <- B.add (make_tau_bound t) v'.v_lbounds - | Var v, _ -> - add_constraint (Unification (t, copy_toplevel t')); - add_constraint (Leq (t, t')) - | _, Var v -> - add_constraint (Unification (t', copy_toplevel t)); - add_constraint (Leq (t, t')) - | Ref r, Ref r' -> leq_ref (r, r') - | Fun f, Fun f' -> - (* TODO: check, why not do subtyping here? *) - add_constraint (Unification (t, t')) - | Pair pr, Pair pr' -> - add_constraint (Leq (pr.ptr, pr'.ptr)); - add_constraint (Leq (pr.lam, pr'.lam)) - | _ -> raise Inconsistent -and leq_ref (ri, ri') : unit = - leq_c_absloc (ri.rl, ri'.rl); - add_constraint (Unification (ri.points_to, ri'.points_to)) -and leq_c_absloc (l, l') : unit = - let li, li' = find l, find l' in - if !debug_constraints then - Printf.printf - "%s <= %s\n" - (string_of_c_absloc l) - (string_of_c_absloc l'); - if U.equal (l, l') then () - else - begin - li.ubounds <- B.add (make_bound l') li.ubounds; - li'.lbounds <- B.add (make_bound l) li'.lbounds - end -and add_constraint_int (c : tconstraint) (toplev : bool) = - if !debug_constraints && toplev then - begin - Printf.printf "%d:>" !toplev_count; - print_constraint c; - incr toplev_count - end - else - if !debug_constraints then print_constraint c else (); - insist (can_add_constraints ()) - "can't add constraints after compute_results is called"; - begin - match c with - Unification _ -> Q.add c eq_worklist - | Leq _ -> Q.add c leq_worklist - end; - solve_constraints () (* solve online *) -and add_constraint (c : tconstraint) = - add_constraint_int c false -and add_toplev_constraint (c : tconstraint) = - if !print_constraints && not !debug_constraints then - begin - Printf.printf "%d:>" !toplev_count; - incr toplev_count; - print_constraint c - end - else (); - add_constraint_int c true -and fetch_constraint () : tconstraint option = - try Some (Q.take eq_worklist) - with Q.Empty -> - begin - try Some (Q.take leq_worklist) - with Q.Empty -> None - end -(** The main solver loop. *) -and solve_constraints () : unit = - match fetch_constraint () with - None -> () - | Some c -> - begin - match c with - Unification (t, t') -> unify_int (t, t') - | Leq (t, t') -> - if !no_sub then unify_int (t, t') - else leq_int (t, t') - end; - solve_constraints () - -(***********************************************************************) -(* *) -(* Interface Functions *) -(* *) -(***********************************************************************) - -(** Return the contents of the lvalue. *) -let rvalue (lv : lvalue) : tau = - lv.contents - -(** Dereference the rvalue. If it does not have enough structure to - support the operation, then the correct structure is added via new - unification constraints. *) -let rec deref (t : tau) : lvalue = - match find t with - Pair p -> - begin - match find p.ptr with - | Var _ -> - let is_top = top_tau p.ptr in - let points_to = fresh_var is_top in - let l = fresh_c_absloc is_top in - let r = make_ref (l, points_to) - in - add_toplev_constraint (Unification (p.ptr, r)); - make_lval (l, points_to) - | Ref r -> make_lval (r.rl, r.points_to) - | _ -> raise WellFormed - end - | Var v -> - let is_top = top_tau t in - add_toplev_constraint - (Unification (t, make_pair (fresh_var is_top, fresh_var is_top))); - deref t - | _ -> raise WellFormed - - -(** Form the union of [t] and [t'], if it doesn't exist already. *) -let join (t : tau) (t' : tau) : tau = - let s, s' = get_stamp t, get_stamp t' in - try H.find join_cache (s, s') - with Not_found -> - let t'' = fresh_var false in - add_toplev_constraint (Leq (t, t'')); - add_toplev_constraint (Leq (t', t'')); - H.add join_cache (s, s') t''; - t'' - -(** Form the union of a list [tl], expected to be the initializers of some - structure or array type. *) -let join_inits (tl : tau list) : tau = - let t' = fresh_var false in - List.iter (function t -> add_toplev_constraint (Leq (t, t'))) tl; - t' - -(** Take the address of an lvalue. Does not add constraints. *) -let address (lv : lvalue) : tau = - make_pair (make_ref (lv.l, lv.contents), fresh_var false ) - -(** No instantiation in this analysis *) -let instantiate (lv : lvalue) (i : int) : lvalue = - lv - -(** Constraint generated from assigning [t] to [lv]. *) -let assign (lv : lvalue) (t : tau) : unit = - add_toplev_constraint (Leq (t, lv.contents)) - -let assign_ret (i : int) (lv : lvalue) (t : tau) : unit = - add_toplev_constraint (Leq (t, lv.contents)) - -(** Project out the first (ref) component or a pair. If the argument - [t] has no discovered structure, raise NoContents. *) -let proj_ref (t : tau) : tau = - match find t with - Pair p -> p.ptr - | Var v -> raise NoContents - | _ -> raise WellFormed - -(* Project out the second (fun) component of a pair. If the argument - [t] has no discovered structure, create it on the fly by adding - constraints. *) -let proj_fun (t : tau) : tau = - match find t with - Pair p -> p.lam - | Var v -> - let p, f = fresh_var false, fresh_var false in - add_toplev_constraint (Unification (t, make_pair (p, f))); - f - | _ -> raise WellFormed - -let get_args (t : tau) : tau list = - match find t with - Fun f -> f.args - | _ -> raise WellFormed - -let get_finfo (t : tau) : finfo = - match find t with - Fun f -> f - | _ -> raise WellFormed - -(** Function type [t] is applied to the arguments [actuals]. Unifies - the actuals with the formals of [t]. If no functions have been - discovered for [t] yet, create a fresh one and unify it with - t. The result is the return value of the function plus the index - of this application site. - - For this analysis, the application site is always 0 *) -let apply (t : tau) (al : tau list) : (tau * int) = - let f = proj_fun t in - let actuals = ref al in - let fi, ret = - match find f with - Fun fi -> fi, fi.ret - | Var v -> - let new_l, new_ret, new_args = - fresh_c_absloc false, - fresh_var false, - List.map (function _ -> fresh_var false) !actuals - in - let new_fun = make_fun (new_l, new_args, new_ret) in - add_toplev_constraint (Unification (new_fun, f)); - (get_finfo new_fun, new_ret) - | _ -> raise WellFormed - in - pad_args (fi, actuals); - List.iter2 - (fun actual -> fun formal -> - add_toplev_constraint (Leq (actual, formal))) - !actuals fi.args; - (ret, 0) - -let make_undefined_lvalue () = - make_lval (make_c_absloc false "undefined" None, - make_var true "undefined") - -let make_undefined_rvalue () = - make_var true "undefined" - -let assign_undefined (lv : lvalue) : unit = - assign lv (make_undefined_rvalue ()) - -let apply_undefined (al : tau list) : (tau * int) = - List.iter - (fun actual -> assign (make_undefined_lvalue ()) actual) - al; - (fresh_var true, 0) - -(** Create a new function type with name [name], list of formal - arguments [formals], and return value [ret]. Adds no constraints. *) -let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = - let f = make_fun (make_c_absloc false name None, - List.map (fun x -> rvalue x) formals, - ret) - in - make_pair (fresh_var false, f) - -(** Create an lvalue. *) -let make_lvalue (b : bool ) (name : string) (vio : Cil.varinfo option) = - make_lval (make_c_absloc false name vio, - make_var false name) - -(** Create a fresh named variable. *) -let make_fresh (name : string) : tau = - make_var false name - -(** The default type for abslocs. *) -let bottom () : tau = - make_var false "bottom" - -(** Unify the result of a function with its return value. *) -let return (t : tau) (t' : tau) = - add_toplev_constraint (Leq (t', t)) - -(***********************************************************************) -(* *) -(* Query/Extract Solutions *) -(* *) -(***********************************************************************) - -module IntHash = Hashtbl.Make (struct - type t = int - let equal x y = x = y - let hash x = x - end) - -(** todo : reached_top !! *) -let collect_ptset_fast (l : c_absloc) : abslocset = - let onpath : unit IntHash.t = IntHash.create 101 in - let path : c_absloc list ref = ref [] in - let compute_path (i : int) = - keep_until (fun l -> i = get_c_absloc_stamp l) !path in - let collapse_cycle (cycle : c_absloc list) = - match cycle with - l :: ls -> - List.iter (fun l' -> unify_c_abslocs (l, l')) ls; - C.empty - | [] -> die "collapse cycle" in - let rec flow_step (l : c_absloc) : abslocset = - let stamp = get_c_absloc_stamp l in - if IntHash.mem onpath stamp then (* already seen *) - collapse_cycle (compute_path stamp) - else - let li = find l in - IntHash.add onpath stamp (); - path := l :: !path; - B.iter - (fun lb -> li.aliases <- C.union li.aliases (flow_step lb.info)) - li.lbounds; - path := List.tl !path; - IntHash.remove onpath stamp; - li.aliases - in - insist (can_query_graph ()) "collect_ptset_fast can't query graph"; - if get_flow_computed l then get_aliases l - else - begin - set_flow_computed l; - flow_step l - end - -(** this is a quadratic flow step. keep it for debugging the fast - version above. *) -let collect_ptset_slow (l : c_absloc) : abslocset = - let onpath : unit IntHash.t = IntHash.create 101 in - let rec flow_step (l : c_absloc) : abslocset = - if top_c_absloc l then raise ReachedTop - else - let stamp = get_c_absloc_stamp l in - if IntHash.mem onpath stamp then C.empty - else - let li = find l in - IntHash.add onpath stamp (); - B.iter - (fun lb -> li.aliases <- C.union li.aliases (flow_step lb.info)) - li.lbounds; - li.aliases - in - insist (can_query_graph ()) "collect_ptset_slow can't query graph"; - if get_flow_computed l then get_aliases l - else - begin - set_flow_computed l; - flow_step l - end - -let collect_ptset = - collect_ptset_slow - (* if !debug_flow_step then collect_ptset_slow - else collect_ptset_fast *) - -let may_alias (t1 : tau) (t2 : tau) : bool = - let get_l (t : tau) : c_absloc = - match find (proj_ref t) with - Ref r -> r.rl - | Var v -> raise NoContents - | _ -> raise WellFormed - in - try - let l1 = get_l t1 - and l2 = get_l t2 in - equal_c_absloc l1 l2 || - not (C.is_empty (C.inter (collect_ptset l1) (collect_ptset l2))) - with - NoContents -> false - | ReachedTop -> raise UnknownLocation - -let points_to_aux (t : tau) : absloc list = - try - match find (proj_ref t) with - Var v -> [] - | Ref r -> C.elements (collect_ptset r.rl) - | _ -> raise WellFormed - with - NoContents -> [] - | ReachedTop -> raise UnknownLocation - -let points_to (lv : lvalue) : Cil.varinfo list = - let rec get_vinfos l : Cil.varinfo list = - match l with - [] -> [] - | (_, _, Some h) :: t -> h :: get_vinfos t - | (_, _, None) :: t -> get_vinfos t - in - get_vinfos (points_to_aux lv.contents) - -let epoints_to (t : tau) : Cil.varinfo list = - let rec get_vinfos l : Cil.varinfo list = match l with - [] -> [] - | (_, _, Some h) :: t -> h :: get_vinfos t - | (_, _, None) :: t -> get_vinfos t - in - get_vinfos (points_to_aux t) - -let points_to_names (lv : lvalue) : string list = - List.map (fun v -> v.vname) (points_to lv) - -let absloc_points_to (lv : lvalue) : absloc list = - points_to_aux lv.contents - -let absloc_epoints_to (t : tau) : absloc list = - points_to_aux t - -let absloc_of_lvalue (lv : lvalue) : absloc = - (find lv.l).loc - -let absloc_eq = equal_absloc diff --git a/cil/src/ext/pta/olf.mli b/cil/src/ext/pta/olf.mli deleted file mode 100644 index 4379482..0000000 --- a/cil/src/ext/pta/olf.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -type lvalue -type tau -type absloc - -(** Raised if a pointer flows to an undefined function. - We assume that such a function can have any effect on the pointer's contents -*) -exception UnknownLocation - -val debug : bool ref -val debug_constraints : bool ref -val debug_aliases : bool ref -val smart_aliases : bool ref -val finished_constraints : unit -> unit -val print_constraints : bool ref -val no_flow : bool ref -val no_sub : bool ref -val analyze_mono : bool ref -val solve_constraints : unit -> unit (* only for compatability with Golf *) -val rvalue : lvalue -> tau -val deref : tau -> lvalue -val join : tau -> tau -> tau -val join_inits : tau list -> tau -val address : lvalue -> tau -val instantiate : lvalue -> int -> lvalue -val assign : lvalue -> tau -> unit -val assign_ret : int -> lvalue -> tau -> unit -val apply : tau -> tau list -> (tau * int) -val apply_undefined : tau list -> (tau * int) -val assign_undefined : lvalue -> unit -val make_function : string -> lvalue list -> tau -> tau -val make_lvalue : bool -> string -> (Cil.varinfo option) -> lvalue -val bottom : unit -> tau -val return : tau -> tau -> unit -val make_fresh : string -> tau -val points_to_names : lvalue -> string list -val points_to : lvalue -> Cil.varinfo list -val epoints_to : tau -> Cil.varinfo list -val string_of_lvalue : lvalue -> string -val may_alias : tau -> tau -> bool - -val absloc_points_to : lvalue -> absloc list -val absloc_epoints_to : tau -> absloc list -val absloc_of_lvalue : lvalue -> absloc -val absloc_eq : (absloc * absloc) -> bool -val d_absloc : unit -> absloc -> Pretty.doc diff --git a/cil/src/ext/pta/ptranal.ml b/cil/src/ext/pta/ptranal.ml deleted file mode 100644 index c91bda8..0000000 --- a/cil/src/ext/pta/ptranal.ml +++ /dev/null @@ -1,597 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -exception Bad_return -exception Bad_function - - -open Cil - -module H = Hashtbl - -module A = Olf -exception UnknownLocation = A.UnknownLocation - -type access = A.lvalue * bool - -type access_map = (lval, access) H.t - -(** a mapping from varinfo's back to fundecs *) -module VarInfoKey = -struct - type t = varinfo - let compare v1 v2 = v1.vid - v2.vid -end - -module F = Map.Make (VarInfoKey) - - -(***********************************************************************) -(* *) -(* Global Variables *) -(* *) -(***********************************************************************) - -let model_strings = ref false -let print_constraints = A.print_constraints -let debug_constraints = A.debug_constraints -let debug_aliases = A.debug_aliases -let smart_aliases = A.smart_aliases -let debug = A.debug -let analyze_mono = A.analyze_mono -let no_flow = A.no_flow -let no_sub = A.no_sub -let fun_ptrs_as_funs = ref false -let show_progress = ref false -let debug_may_aliases = ref false - -let found_undefined = ref false - -let conservative_undefineds = ref false - -let current_fundec : fundec option ref = ref None - -let fun_access_map : (fundec, access_map) H.t = H.create 64 - -(* A mapping from varinfos to fundecs *) -let fun_varinfo_map = ref F.empty - -let current_ret : A.tau option ref = ref None - -let lvalue_hash : (varinfo,A.lvalue) H.t = H.create 64 - -let expressions : (exp,A.tau) H.t = H.create 64 - -let lvalues : (lval,A.lvalue) H.t = H.create 64 - -let fresh_index : (unit -> int) = - let count = ref 0 in - fun () -> - incr count; - !count - -let alloc_names = [ - "malloc"; - "calloc"; - "realloc"; - "xmalloc"; - "__builtin_alloca"; - "alloca"; - "kmalloc" -] - -let all_globals : varinfo list ref = ref [] -let all_functions : fundec list ref = ref [] - - -(***********************************************************************) -(* *) -(* Utility Functions *) -(* *) -(***********************************************************************) - -let is_undefined_fun = function - Lval (lh, o) -> - if isFunctionType (typeOfLval (lh, o)) then - match lh with - Var v -> v.vstorage = Extern - | _ -> false - else false - | _ -> false - -let is_alloc_fun = function - Lval (lh, o) -> - if isFunctionType (typeOfLval (lh, o)) then - match lh with - Var v -> List.mem v.vname alloc_names - | _ -> false - else false - | _ -> false - -let next_alloc = function - Lval (Var v, o) -> - let name = Printf.sprintf "%s@%d" v.vname (fresh_index ()) - in - A.address (A.make_lvalue false name (Some v)) (* check *) - | _ -> raise Bad_return - -let is_effect_free_fun = function - Lval (lh, o) when isFunctionType (typeOfLval (lh, o)) -> - begin - match lh with - Var v -> - begin - try ("CHECK_" = String.sub v.vname 0 6) - with Invalid_argument _ -> false - end - | _ -> false - end - | _ -> false - - -(***********************************************************************) -(* *) -(* AST Traversal Functions *) -(* *) -(***********************************************************************) - -(* should do nothing, might need to worry about Index case *) -(* let analyzeOffset (o : offset ) : A.tau = A.bottom () *) - -let analyze_var_decl (v : varinfo ) : A.lvalue = - try H.find lvalue_hash v - with Not_found -> - let lv = A.make_lvalue false v.vname (Some v) - in - H.add lvalue_hash v lv; - lv - -let isFunPtrType (t : typ) : bool = - match t with - TPtr (t, _) -> isFunctionType t - | _ -> false - -let rec analyze_lval (lv : lval ) : A.lvalue = - let find_access (l : A.lvalue) (is_var : bool) : A.lvalue = - match !current_fundec with - None -> l - | Some f -> - let accesses = H.find fun_access_map f in - if H.mem accesses lv then l - else - begin - H.add accesses lv (l, is_var); - l - end in - let result = - match lv with - Var v, _ -> (* instantiate every syntactic occurrence of a function *) - let alv = - if isFunctionType (typeOfLval lv) then - A.instantiate (analyze_var_decl v) (fresh_index ()) - else analyze_var_decl v - in - find_access alv true - | Mem e, _ -> - (* assert (not (isFunctionType(typeOf(e))) ); *) - let alv = - if !fun_ptrs_as_funs && isFunPtrType (typeOf e) then - analyze_expr_as_lval e - else A.deref (analyze_expr e) - in - find_access alv false - in - H.replace lvalues lv result; - result -and analyze_expr_as_lval (e : exp) : A.lvalue = - match e with - Lval l -> analyze_lval l - | _ -> assert false (* todo -- other kinds of expressions? *) -and analyze_expr (e : exp ) : A.tau = - let result = - match e with - Const (CStr s) -> - if !model_strings then - A.address (A.make_lvalue - false - s - (Some (makeVarinfo false s charConstPtrType))) - else A.bottom () - | Const c -> A.bottom () - | Lval l -> A.rvalue (analyze_lval l) - | SizeOf _ -> A.bottom () - | SizeOfStr _ -> A.bottom () - | AlignOf _ -> A.bottom () - | UnOp (op, e, t) -> analyze_expr e - | BinOp (op, e, e', t) -> A.join (analyze_expr e) (analyze_expr e') - | CastE (t, e) -> analyze_expr e - | AddrOf l -> - if !fun_ptrs_as_funs && isFunctionType (typeOfLval l) then - A.rvalue (analyze_lval l) - else A.address (analyze_lval l) - | StartOf l -> A.address (analyze_lval l) - | AlignOfE _ -> A.bottom () - | SizeOfE _ -> A.bottom () - in - H.add expressions e result; - result - - -(* check *) -let rec analyze_init (i : init ) : A.tau = - match i with - SingleInit e -> analyze_expr e - | CompoundInit (t, oi) -> - A.join_inits (List.map (function (_, i) -> analyze_init i) oi) - -let analyze_instr (i : instr ) : unit = - match i with - Set (lval, rhs, l) -> - A.assign (analyze_lval lval) (analyze_expr rhs) - | Call (res, fexpr, actuals, l) -> - if not (isFunctionType (typeOf fexpr)) then - () (* todo : is this a varargs? *) - else if is_alloc_fun fexpr then - begin - if !debug then print_string "Found allocation function...\n"; - match res with - Some r -> A.assign (analyze_lval r) (next_alloc fexpr) - | None -> () - end - else if is_effect_free_fun fexpr then - List.iter (fun e -> ignore (analyze_expr e)) actuals - else (* todo : check to see if the thing is an undefined function *) - let fnres, site = - if is_undefined_fun fexpr & !conservative_undefineds then - A.apply_undefined (List.map analyze_expr actuals) - else - A.apply (analyze_expr fexpr) (List.map analyze_expr actuals) - in - begin - match res with - Some r -> - begin - A.assign_ret site (analyze_lval r) fnres; - found_undefined := true; - end - | None -> () - end - | Asm _ -> () - -let rec analyze_stmt (s : stmt ) : unit = - match s.skind with - Instr il -> List.iter analyze_instr il - | Return (eo, l) -> - begin - match eo with - Some e -> - begin - match !current_ret with - Some ret -> A.return ret (analyze_expr e) - | None -> raise Bad_return - end - | None -> () - end - | Goto (s', l) -> () (* analyze_stmt(!s') *) - | If (e, b, b', l) -> - (* ignore the expression e; expressions can't be side-effecting *) - analyze_block b; - analyze_block b' - | Switch (e, b, sl, l) -> - analyze_block b; - List.iter analyze_stmt sl -(* - | Loop (b, l, _, _) -> analyze_block b -*) - | While (_, b, _) -> analyze_block b - | DoWhile (_, b, _) -> analyze_block b - | For (bInit, _, bIter, b, _) -> - analyze_block bInit; - analyze_block bIter; - analyze_block b - | Block b -> analyze_block b - | TryFinally (b, h, _) -> - analyze_block b; - analyze_block h - | TryExcept (b, (il, _), h, _) -> - analyze_block b; - List.iter analyze_instr il; - analyze_block h - | Break l -> () - | Continue l -> () - - -and analyze_block (b : block ) : unit = - List.iter analyze_stmt b.bstmts - -let analyze_function (f : fundec ) : unit = - let oldlv = analyze_var_decl f.svar in - let ret = A.make_fresh (f.svar.vname ^ "_ret") in - let formals = List.map analyze_var_decl f.sformals in - let newf = A.make_function f.svar.vname formals ret in - if !show_progress then - Printf.printf "Analyzing function %s\n" f.svar.vname; - fun_varinfo_map := F.add f.svar f (!fun_varinfo_map); - current_fundec := Some f; - H.add fun_access_map f (H.create 8); - A.assign oldlv newf; - current_ret := Some ret; - analyze_block f.sbody - -let analyze_global (g : global ) : unit = - match g with - GVarDecl (v, l) -> () (* ignore (analyze_var_decl(v)) -- no need *) - | GVar (v, init, l) -> - all_globals := v :: !all_globals; - begin - match init.init with - Some i -> A.assign (analyze_var_decl v) (analyze_init i) - | None -> ignore (analyze_var_decl v) - end - | GFun (f, l) -> - all_functions := f :: !all_functions; - analyze_function f - | _ -> () - -let analyze_file (f : file) : unit = - iterGlobals f analyze_global - - -(***********************************************************************) -(* *) -(* High-level Query Interface *) -(* *) -(***********************************************************************) - -(* Same as analyze_expr, but no constraints. *) -let rec traverse_expr (e : exp) : A.tau = - H.find expressions e - -and traverse_expr_as_lval (e : exp) : A.lvalue = - match e with - | Lval l -> traverse_lval l - | _ -> assert false (* todo -- other kinds of expressions? *) - -and traverse_lval (lv : lval ) : A.lvalue = - H.find lvalues lv - -let may_alias (e1 : exp) (e2 : exp) : bool = - let tau1,tau2 = traverse_expr e1, traverse_expr e2 in - let result = A.may_alias tau1 tau2 in - if !debug_may_aliases then - begin - let doc1 = d_exp () e1 in - let doc2 = d_exp () e2 in - let s1 = Pretty.sprint ~width:30 doc1 in - let s2 = Pretty.sprint ~width:30 doc2 in - Printf.printf - "%s and %s may alias? %s\n" - s1 - s2 - (if result then "yes" else "no") - end; - result - -let resolve_lval (lv : lval) : varinfo list = - A.points_to (traverse_lval lv) - -let resolve_exp (e : exp) : varinfo list = - A.epoints_to (traverse_expr e) - -let resolve_funptr (e : exp) : fundec list = - let varinfos = A.epoints_to (traverse_expr e) in - List.fold_left - (fun fdecs -> fun vinf -> - try F.find vinf !fun_varinfo_map :: fdecs - with Not_found -> fdecs) - [] - varinfos - -let count_hash_elts h = - let result = ref 0 in - H.iter (fun _ -> fun _ -> incr result) lvalue_hash; - !result - -let compute_may_aliases (b : bool) : unit = - let rec compute_may_aliases_aux (exps : exp list) = - match exps with - [] -> () - | h :: t -> - ignore (List.map (may_alias h) t); - compute_may_aliases_aux t - and exprs : exp list ref = ref [] in - H.iter (fun e -> fun _ -> exprs := e :: !exprs) expressions; - compute_may_aliases_aux !exprs - - -let compute_results (show_sets : bool) : unit = - let total_pointed_to = ref 0 - and total_lvalues = H.length lvalue_hash - and counted_lvalues = ref 0 - and lval_elts : (string * (string list)) list ref = ref [] in - let print_result (name, set) = - let rec print_set s = - match s with - [] -> () - | h :: [] -> print_string h - | h :: t -> - print_string (h ^ ", "); - print_set t - and ptsize = List.length set in - total_pointed_to := !total_pointed_to + ptsize; - if ptsize > 0 then - begin - print_string (name ^ "(" ^ (string_of_int ptsize) ^ ") -> "); - print_set set; - print_newline () - end - in - (* Make the most pessimistic assumptions about globals if an - undefined function is present. Such a function can write to every - global variable *) - let hose_globals () : unit = - List.iter - (fun vd -> A.assign_undefined (analyze_var_decl vd)) - !all_globals - in - let show_progress_fn (counted : int ref) (total : int) : unit = - incr counted; - if !show_progress then - Printf.printf "Computed flow for %d of %d sets\n" !counted total - in - if !conservative_undefineds && !found_undefined then hose_globals (); - A.finished_constraints (); - if show_sets then - begin - print_endline "Computing points-to sets..."; - Hashtbl.iter - (fun vinf -> fun lv -> - show_progress_fn counted_lvalues total_lvalues; - try lval_elts := (vinf.vname, A.points_to_names lv) :: !lval_elts - with A.UnknownLocation -> ()) - lvalue_hash; - List.iter print_result !lval_elts; - Printf.printf - "Total number of things pointed to: %d\n" - !total_pointed_to - end; - if !debug_may_aliases then - begin - Printf.printf "Printing may alias relationships\n"; - compute_may_aliases true - end - -let print_types () : unit = - print_string "Printing inferred types of lvalues...\n"; - Hashtbl.iter - (fun vi -> fun lv -> - Printf.printf "%s : %s\n" vi.vname (A.string_of_lvalue lv)) - lvalue_hash - - - -(** Alias queries. For each function, gather sets of locals, formals, and - globals. Do n^2 work for each of these functions, reporting whether or not - each pair of values is aliased. Aliasing is determined by taking points-to - set intersections. -*) -let compute_aliases = compute_may_aliases - - -(***********************************************************************) -(* *) -(* Abstract Location Interface *) -(* *) -(***********************************************************************) - -type absloc = A.absloc - -let rec lvalue_of_varinfo (vi : varinfo) : A.lvalue = - H.find lvalue_hash vi - -let lvalue_of_lval = traverse_lval -let tau_of_expr = traverse_expr - -(** return an abstract location for a varinfo, resp. lval *) -let absloc_of_varinfo vi = - A.absloc_of_lvalue (lvalue_of_varinfo vi) - -let absloc_of_lval lv = - A.absloc_of_lvalue (lvalue_of_lval lv) - -let absloc_e_points_to e = - A.absloc_epoints_to (tau_of_expr e) - -let absloc_lval_aliases lv = - A.absloc_points_to (lvalue_of_lval lv) - -(* all abslocs that e transitively points to *) -let absloc_e_transitive_points_to (e : Cil.exp) : absloc list = - let rec lv_trans_ptsto (worklist : varinfo list) (acc : varinfo list) : absloc list = - match worklist with - [] -> List.map absloc_of_varinfo acc - | vi :: wklst'' -> - if List.mem vi acc then lv_trans_ptsto wklst'' acc - else - lv_trans_ptsto - (List.rev_append - (A.points_to (lvalue_of_varinfo vi)) - wklst'') - (vi :: acc) - in - lv_trans_ptsto (A.epoints_to (tau_of_expr e)) [] - -let absloc_eq a b = A.absloc_eq (a, b) - -let d_absloc: unit -> absloc -> Pretty.doc = A.d_absloc - - -let ptrAnalysis = ref false -let ptrResults = ref false -let ptrTypes = ref false - - - -(** Turn this into a CIL feature *) -let feature : featureDescr = { - fd_name = "ptranal"; - fd_enabled = ptrAnalysis; - fd_description = "alias analysis"; - fd_extraopt = [ - ("--ptr_may_aliases", - Arg.Unit (fun _ -> debug_may_aliases := true), - "Print out results of may alias queries"); - ("--ptr_unify", Arg.Unit (fun _ -> no_sub := true), - "Make the alias analysis unification-based"); - ("--ptr_model_strings", Arg.Unit (fun _ -> model_strings := true), - "Make the alias analysis model string constants"); - ("--ptr_conservative", - Arg.Unit (fun _ -> conservative_undefineds := true), - "Treat undefineds conservatively in alias analysis"); - ("--ptr_results", Arg.Unit (fun _ -> ptrResults := true), - "print the results of the alias analysis"); - ("--ptr_mono", Arg.Unit (fun _ -> analyze_mono := true), - "run alias analysis monomorphically"); - ("--ptr_types",Arg.Unit (fun _ -> ptrTypes := true), - "print inferred points-to analysis types") - ]; - fd_doit = (function (f: file) -> - analyze_file f; - compute_results !ptrResults; - if !ptrTypes then print_types ()); - fd_post_check = false (* No changes *) -} diff --git a/cil/src/ext/pta/ptranal.mli b/cil/src/ext/pta/ptranal.mli deleted file mode 100644 index 36eb7a5..0000000 --- a/cil/src/ext/pta/ptranal.mli +++ /dev/null @@ -1,156 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(***********************************************************************) -(* *) -(* Flags *) -(* *) -(***********************************************************************) - -(** Print extra debugging info *) -val debug : bool ref - -(** Debug constraints (print all constraints) *) -val debug_constraints : bool ref - -(** Debug smart alias queries *) -val debug_aliases : bool ref - -(** Debug may alias queries *) -val debug_may_aliases : bool ref - -val smart_aliases : bool ref - -(** Print out the top level constraints *) -val print_constraints : bool ref - -(** Make the analysis monomorphic *) -val analyze_mono : bool ref - -(** Disable subtyping *) -val no_sub : bool ref - -(** Make the flow step a no-op *) -val no_flow : bool ref - -(** Show the progress of the flow step *) -val show_progress : bool ref - -(** Treat undefined functions conservatively *) -val conservative_undefineds : bool ref - -(***********************************************************************) -(* *) -(* Building the Points-to Graph *) -(* *) -(***********************************************************************) - -(** Analyze a file *) -val analyze_file : Cil.file -> unit - -(** Print the type of each lvalue in the program *) -val print_types : unit -> unit - -(***********************************************************************) -(* *) -(* High-level Query Interface *) -(* *) -(***********************************************************************) - -(** If undefined functions are analyzed conservatively, any of the - high-level queries may raise this exception *) -exception UnknownLocation - -val may_alias : Cil.exp -> Cil.exp -> bool - -val resolve_lval : Cil.lval -> (Cil.varinfo list) - -val resolve_exp : Cil.exp -> (Cil.varinfo list) - -val resolve_funptr : Cil.exp -> (Cil.fundec list) - -(***********************************************************************) -(* *) -(* Low-level Query Interface *) -(* *) -(***********************************************************************) - -(** type for abstract locations *) -type absloc - -(** Give an abstract location for a varinfo *) -val absloc_of_varinfo : Cil.varinfo -> absloc - -(** Give an abstract location for an Cil lvalue *) -val absloc_of_lval : Cil.lval -> absloc - -(** may the two abstract locations be aliased? *) -val absloc_eq : absloc -> absloc -> bool - -val absloc_e_points_to : Cil.exp -> absloc list -val absloc_e_transitive_points_to : Cil.exp -> absloc list - -val absloc_lval_aliases : Cil.lval -> absloc list - -(** Print a string representing an absloc, for debugging. *) -val d_absloc : unit -> absloc -> Pretty.doc - - -(***********************************************************************) -(* *) -(* Printing results *) -(* *) -(***********************************************************************) - -(** Compute points to sets for variables. If true is passed, print the sets. *) -val compute_results : bool -> unit - -(* - -Deprecated these. -- jk - -(** Compute alias relationships. If true is passed, print all alias pairs. *) - val compute_aliases : bool -> unit - -(** Compute alias frequncy *) -val compute_alias_frequency : unit -> unit - - -*) - -val compute_aliases : bool -> unit - - -val feature: Cil.featureDescr diff --git a/cil/src/ext/pta/setp.ml b/cil/src/ext/pta/setp.ml deleted file mode 100644 index a39b972..0000000 --- a/cil/src/ext/pta/setp.ml +++ /dev/null @@ -1,342 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: setp.ml,v 1.3 2003-02-19 19:26:31 jkodumal Exp $ *) - -(* Sets over ordered types *) - -module type PolyOrderedType = - sig - type 'a t - val compare: 'a t -> 'a t -> int - end - -module type S = - sig - type 'a elt - type 'a t - val empty: 'a t - val is_empty: 'a t -> bool - val mem: 'a elt -> 'a t -> bool - val add: 'a elt -> 'a t -> 'a t - val singleton: 'a elt -> 'a t - val remove: 'a elt -> 'a t -> 'a t - val union: 'a t -> 'a t -> 'a t - val inter: 'a t -> 'a t -> 'a t - val diff: 'a t -> 'a t -> 'a t - val compare: 'a t -> 'a t -> int - val equal: 'a t -> 'a t -> bool - val subset: 'a t -> 'a t -> bool - val iter: ('a elt -> unit) -> 'a t -> unit - val fold: ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b - val for_all: ('a elt -> bool) -> 'a t -> bool - val exists: ('a elt -> bool) -> 'a t -> bool - val filter: ('a elt -> bool) -> 'a t -> 'a t - val partition: ('a elt -> bool) -> 'a t -> 'a t * 'a t - val cardinal: 'a t -> int - val elements: 'a t -> 'a elt list - val min_elt: 'a t -> 'a elt - val max_elt: 'a t -> 'a elt - val choose: 'a t -> 'a elt - end - -module Make(Ord: PolyOrderedType) = - struct - type 'a elt = 'a Ord.t - type 'a t = Empty | Node of 'a t * 'a elt * 'a t * int - - (* Sets are represented by balanced binary trees (the heights of the - children differ by at most 2 *) - - let height = function - Empty -> 0 - | Node(_, _, _, h) -> h - - (* Creates a new node with left son l, value x and right son r. - l and r must be balanced and | height l - height r | <= 2. - Inline expansion of height for better speed. *) - - let create l x r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) - - (* Same as create, but performs one step of rebalancing if necessary. - Assumes l and r balanced. - Inline expansion of create for better speed in the most frequent case - where no rebalancing is required. *) - - let bal l x r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Set.bal" - | Node(ll, lv, lr, _) -> - if height ll >= height lr then - create ll lv (create lr x r) - else begin - match lr with - Empty -> invalid_arg "Set.bal" - | Node(lrl, lrv, lrr, _)-> - create (create ll lv lrl) lrv (create lrr x r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Set.bal" - | Node(rl, rv, rr, _) -> - if height rr >= height rl then - create (create l x rl) rv rr - else begin - match rl with - Empty -> invalid_arg "Set.bal" - | Node(rll, rlv, rlr, _) -> - create (create l x rll) rlv (create rlr rv rr) - end - end else - Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) - - (* Same as bal, but repeat rebalancing until the final result - is balanced. *) - - let rec join l x r = - match bal l x r with - Empty -> invalid_arg "Set.join" - | Node(l', x', r', _) as t' -> - let d = height l' - height r' in - if d < -2 || d > 2 then join l' x' r' else t' - - (* Merge two trees l and r into one. - All elements of l must precede the elements of r. - Assumes | height l - height r | <= 2. *) - - let rec merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - bal l1 v1 (bal (merge r1 l2) v2 r2) - - (* Same as merge, but does not assume anything about l and r. *) - - let rec concat t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - join l1 v1 (join (concat r1 l2) v2 r2) - - (* Splitting *) - - let rec split x = function - Empty -> - (Empty, None, Empty) - | Node(l, v, r, _) -> - let c = Ord.compare x v in - if c = 0 then (l, Some v, r) - else if c < 0 then - let (ll, vl, rl) = split x l in (ll, vl, join rl v r) - else - let (lr, vr, rr) = split x r in (join l v lr, vr, rr) - - (* Implementation of the set operations *) - - let empty = Empty - - let is_empty = function Empty -> true | _ -> false - - let rec mem x = function - Empty -> false - | Node(l, v, r, _) -> - let c = Ord.compare x v in - c = 0 || mem x (if c < 0 then l else r) - - let rec add x = function - Empty -> Node(Empty, x, Empty, 1) - | Node(l, v, r, _) as t -> - let c = Ord.compare x v in - if c = 0 then t else - if c < 0 then bal (add x l) v r else bal l v (add x r) - - let singleton x = Node(Empty, x, Empty, 1) - - let rec remove x = function - Empty -> Empty - | Node(l, v, r, _) -> - let c = Ord.compare x v in - if c = 0 then merge l r else - if c < 0 then bal (remove x l) v r else bal l v (remove x r) - - let rec union s1 s2 = - match (s1, s2) with - (Empty, t2) -> t2 - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - if h1 >= h2 then - if h2 = 1 then add v2 s1 else begin - let (l2, _, r2) = split v1 s2 in - join (union l1 l2) v1 (union r1 r2) - end - else - if h1 = 1 then add v1 s2 else begin - let (l1, _, r1) = split v2 s1 in - join (union l1 l2) v2 (union r1 r2) - end - - let rec inter s1 s2 = - match (s1, s2) with - (Empty, t2) -> Empty - | (t1, Empty) -> Empty - | (Node(l1, v1, r1, _), t2) -> - match split v1 t2 with - (l2, None, r2) -> - concat (inter l1 l2) (inter r1 r2) - | (l2, Some _, r2) -> - join (inter l1 l2) v1 (inter r1 r2) - - let rec diff s1 s2 = - match (s1, s2) with - (Empty, t2) -> Empty - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, _), t2) -> - match split v1 t2 with - (l2, None, r2) -> - join (diff l1 l2) v1 (diff r1 r2) - | (l2, Some _, r2) -> - concat (diff l1 l2) (diff r1 r2) - - let rec compare_aux l1 l2 = - match (l1, l2) with - ([], []) -> 0 - | ([], _) -> -1 - | (_, []) -> 1 - | (Empty :: t1, Empty :: t2) -> - compare_aux t1 t2 - | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> - let c = Ord.compare v1 v2 in - if c <> 0 then c else compare_aux (r1::t1) (r2::t2) - | (Node(l1, v1, r1, _) :: t1, t2) -> - compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 - | (t1, Node(l2, v2, r2, _) :: t2) -> - compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) - - let compare s1 s2 = - compare_aux [s1] [s2] - - let equal s1 s2 = - compare s1 s2 = 0 - - let rec subset s1 s2 = - match (s1, s2) with - Empty, _ -> - true - | _, Empty -> - false - | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> - let c = Ord.compare v1 v2 in - if c = 0 then - subset l1 l2 && subset r1 r2 - else if c < 0 then - subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 - else - subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 - - let rec iter f = function - Empty -> () - | Node(l, v, r, _) -> iter f l; f v; iter f r - - let rec fold f s accu = - match s with - Empty -> accu - | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) - - let rec for_all p = function - Empty -> true - | Node(l, v, r, _) -> p v && for_all p l && for_all p r - - let rec exists p = function - Empty -> false - | Node(l, v, r, _) -> p v || exists p l || exists p r - - let filter p s = - let rec filt accu = function - | Empty -> accu - | Node(l, v, r, _) -> - filt (filt (if p v then add v accu else accu) l) r in - filt Empty s - - let partition p s = - let rec part (t, f as accu) = function - | Empty -> accu - | Node(l, v, r, _) -> - part (part (if p v then (add v t, f) else (t, add v f)) l) r in - part (Empty, Empty) s - - let rec cardinal = function - Empty -> 0 - | Node(l, v, r, _) -> cardinal l + 1 + cardinal r - - let rec elements_aux accu = function - Empty -> accu - | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l - - let elements s = - elements_aux [] s - - let rec min_elt = function - Empty -> raise Not_found - | Node(Empty, v, r, _) -> v - | Node(l, v, r, _) -> min_elt l - - let rec max_elt = function - Empty -> raise Not_found - | Node(l, v, Empty, _) -> v - | Node(l, v, r, _) -> max_elt r - - let choose = min_elt - - end diff --git a/cil/src/ext/pta/setp.mli b/cil/src/ext/pta/setp.mli deleted file mode 100644 index a3b3031..0000000 --- a/cil/src/ext/pta/setp.mli +++ /dev/null @@ -1,180 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: setp.mli,v 1.3 2003-02-19 19:26:31 jkodumal Exp $ *) - -(** Sets over ordered types. - - This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses balanced binary trees, and is therefore - reasonably efficient: insertion and membership take time - logarithmic in the size of the set, for instance. -*) - -module type PolyOrderedType = - sig - type 'a t - (** The type of the set elements. *) - val compare : 'a t -> 'a t -> int - (** A total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is - the generic structural comparison function {!Pervasives.compare}. *) - end -(** Input signature of the functor {!Set.Make}. *) - -module type S = - sig - type 'a elt - (** The type of the set elements. *) - - type 'a t - (** The type of sets. *) - - val empty: 'a t - (** The empty set. *) - - val is_empty: 'a t -> bool - (** Test whether a set is empty or not. *) - - val mem: 'a elt -> 'a t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) - - val add: 'a elt -> 'a t -> 'a t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) - - val singleton: 'a elt -> 'a t - (** [singleton x] returns the one-element set containing only [x]. *) - - val remove: 'a elt -> 'a t -> 'a t - (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) - - val union: 'a t -> 'a t -> 'a t - (** Set union. *) - - val inter: 'a t -> 'a t -> 'a t - (** Set interseection. *) - - (** Set difference. *) - val diff: 'a t -> 'a t -> 'a t - - val compare: 'a t -> 'a t -> int - (** Total ordering between sets. Can be used as the ordering function - for doing sets of sets. *) - - val equal: 'a t -> 'a t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) - - val subset: 'a t -> 'a t -> bool - (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) - - val iter: ('a elt -> unit) -> 'a t -> unit - (** [iter f s] applies [f] in turn to all elements of [s]. - The order in which the elements of [s] are presented to [f] - is unspecified. *) - - val fold: ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s]. - The order in which elements of [s] are presented to [f] is - unspecified. *) - - val for_all: ('a elt -> bool) -> 'a t -> bool - (** [for_all p s] checks if all elements of the set - satisfy the predicate [p]. *) - - val exists: ('a elt -> bool) -> 'a t -> bool - (** [exists p s] checks if at least one element of - the set satisfies the predicate [p]. *) - - val filter: ('a elt -> bool) -> 'a t -> 'a t - (** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. *) - - val partition: ('a elt -> bool) -> 'a t -> 'a t * 'a t - (** [partition p s] returns a pair of sets [(s1, s2)], where - [s1] is the set of all the elements of [s] that satisfy the - predicate [p], and [s2] is the set of all the elements of - [s] that do not satisfy [p]. *) - - val cardinal: 'a t -> int - (** Return the number of elements of a set. *) - - val elements: 'a t -> 'a elt list - (** Return the list of all elements of the given set. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Set.Make}. *) - - val min_elt: 'a t -> 'a elt - (** Return the smallest element of the given set - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the set is empty. *) - - val max_elt: 'a t -> 'a elt - (** Same as {!Set.S.min_elt}, but returns the largest element of the - given set. *) - - val choose: 'a t -> 'a elt - (** Return one element of the given set, or raise [Not_found] if - the set is empty. Which element is chosen is unspecified, - but equal elements will be chosen for equal sets. *) - end -(** Output signature of the functor {!Set.Make}. *) - -module Make (Ord : PolyOrderedType) : S with type 'a elt = 'a Ord.t -(** Functor building an implementation of the set structure - given a totally ordered type. *) diff --git a/cil/src/ext/pta/steensgaard.ml b/cil/src/ext/pta/steensgaard.ml deleted file mode 100644 index 6368693..0000000 --- a/cil/src/ext/pta/steensgaard.ml +++ /dev/null @@ -1,1417 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(***********************************************************************) -(* *) -(* *) -(* This file is currently unused by CIL. It is included in the *) -(* distribution for reference only. *) -(* *) -(* *) -(***********************************************************************) - - -(***********************************************************************) -(* *) -(* Type Declarations *) -(* *) -(***********************************************************************) - -exception Inconsistent of string -exception Bad_cache -exception No_contents -exception Bad_proj -exception Bad_type_copy -exception Instantiation_cycle - -module U = Uref -module S = Setp -module H = Hashtbl -module Q = Queue - -(** Polarity kinds-- positive, negative, or nonpolar. *) -type polarity = Pos - | Neg - | Non - -(** Label bounds. The polymorphic type is a hack for recursive modules *) -type 'a bound = {index : int; info : 'a} - -(** The 'a type may in general contain urefs, which makes Pervasives.compare - incorrect. However, the bounds will always be correct because if two tau's - get unified, their cached instantiations will be re-entered into the - worklist, ensuring that any labels find the new bounds *) -module Bound = -struct - type 'a t = 'a bound - let compare (x : 'a t) (y : 'a t) = - Pervasives.compare x y -end - -module B = S.Make(Bound) - -type 'a boundset = 'a B.t - -(** Constants, which identify elements in points-to sets *) -type constant = int * string - -module Constant = -struct - type t = constant - - let compare ((xid,_) : t) ((yid,_) : t) = - Pervasives.compare xid yid -end - -module C = Set.Make(Constant) - -(** Sets of constants. Set union is used when two labels containing - constant sets are unified *) -type constantset = C.t - -type lblinfo = { - mutable l_name: string; - (** Name of this label *) - mutable aliases: constantset; - (** Set of constants (tags) for checking aliases *) - p_bounds: label boundset U.uref; - (** Set of umatched (p) lower bounds *) - n_bounds: label boundset U.uref; - (** Set of unmatched (n) lower bounds *) - mutable p_cached: bool; - (** Flag indicating whether all reachable p edges have been locally cached *) - mutable n_cached: bool; - (** Flag indicating whether all reachable n edges have been locally cached *) - mutable on_path: bool; - (** For cycle detection during reachability queries *) -} - -(** Constructor labels *) -and label = lblinfo U.uref - -(** The type of lvalues. *) -type lvalue = { - l: label; - contents: tau -} - -(** Data for variables. *) -and vinfo = { - v_name: string; - mutable v_global: bool; - v_cache: cache -} - -(** Data for ref constructors. *) -and rinfo = { - rl: label; - mutable r_global: bool; - points_to: tau; - r_cache: cache -} - -(** Data for fun constructors. *) -and finfo = { - fl: label; - mutable f_global: bool; - args: tau list ref; - ret: tau; - f_cache: cache -} - -(* Data for pairs. Note there is no label. *) -and pinfo = { - mutable p_global: bool; - ptr: tau; - lam: tau; - p_cache: cache -} - -(** Type constructors discovered by type inference *) -and tinfo = Wild - | Var of vinfo - | Ref of rinfo - | Fun of finfo - | Pair of pinfo - -(** The top-level points-to type. *) -and tau = tinfo U.uref - -(** The instantiation constraint cache. The index is used as a key. *) -and cache = (int,polarity * tau) H.t - -(* Type of semi-unification constraints *) -type su_constraint = Instantiation of tau * (int * polarity) * tau - | Unification of tau * tau - -(** Association lists, used for printing recursive types. The first element - is a type that has been visited. The second element is the string - representation of that type (so far). If the string option is set, then - this type occurs within itself, and is associated with the recursive var - name stored in the option. When walking a type, add it to an association - list. - - Example : suppose we have the constraint 'a = ref('a). The type is unified - via cyclic unification, and would loop infinitely if we attempted to print - it. What we want to do is print the type u rv. ref(rv). This is accomplished - in the following manner: - - -- ref('a) is visited. It is not in the association list, so it is added - and the string "ref(" is stored in the second element. We recurse to print - the first argument of the constructor. - - -- In the recursive call, we see that 'a (or ref('a)) is already in the - association list, so the type is recursive. We check the string option, - which is None, meaning that this is the first recurrence of the type. We - create a new recursive variable, rv and set the string option to 'rv. Next, - we prepend u rv. to the string representation we have seen before, "ref(", - and return "rv" as the string representation of this type. - - -- The string so far is "u rv.ref(". The recursive call returns, and we - complete the type by printing the result of the call, "rv", and ")" - - In a type where the recursive variable appears twice, e.g. 'a = pair('a,'a), - the second time we hit 'a, the string option will be set, so we know to - reuse the same recursive variable name. -*) -type association = tau * string ref * string option ref - -(***********************************************************************) -(* *) -(* Global Variables *) -(* *) -(***********************************************************************) - -(** Print the instantiations constraints (loops with cyclic structures). *) -let print_constraints : bool ref = ref false - -(** Solve constraints as they are introduced. If this is false, constraints - are solved in batch fashion at calls to solveConstraints. *) -let solve_online : bool ref = ref true - -(** If true, print all constraints (including induced) and show additional - debug output. *) -let debug = ref false -let debug_constraints = debug - -(** If true, print out extra verbose debug information (including contents - of label sets *) -let verbose_debug = ref false - - -(** If true, make the flow step a no-op *) -let no_flow = ref false - -let no_sub = ref false - -(** If true, do not add instantiation constraints *) -let analyze_mono = ref false - -(** A counter for generating unique integers. *) -let counter : int ref = ref 0 - -(** A list of equality constraints. *) -let eq_worklist : su_constraint Q.t = Q.create() - -(** A list of instantiation constraints. *) -let inst_worklist : su_constraint Q.t = Q.create() - -(***********************************************************************) -(* *) -(* Utility Functions *) -(* *) -(***********************************************************************) - -(** Consistency check for inferred types *) -let pair_or_var (t : tau) = - match (U.deref t) with - | Pair _ -> true - | Var _ -> true - | _ -> false - -let ref_or_var (t : tau) = - match (U.deref t) with - | Ref _ -> true - | Var _ -> true - | _ -> false - -let fun_or_var (t : tau) = - match (U.deref t) with - | Fun _ -> true - | Var _ -> true - | _ -> false - -(** Generate a unique integer. *) -let fresh_index () : int = - incr counter; - !counter - -(** Negate a polarity. *) -let negate (p : polarity) : polarity = - match p with - | Pos -> Neg - | Neg -> Pos - | Non -> Non - -(** Compute the least-upper-bounds of two polarities. *) -let lub (p,p' : polarity * polarity) : polarity = - match p with - | Pos -> - begin - match p' with - | Pos -> Pos - | _ -> Non - end - | Neg -> - begin - match p' with - | Neg -> Neg - | _ -> Non - end - | Non -> Non - -(** Extract the cache from a type *) -let get_cache (t : tau) : cache = - match U.deref t with - | Wild -> raise Bad_cache - | Var v -> v.v_cache - | Ref r -> r.r_cache - | Pair p -> p.p_cache - | Fun f -> f.f_cache - -(** Determine whether or not a type is global *) -let get_global (t : tau) : bool = - match U.deref t with - | Wild -> false - | Var v -> v.v_global - | Ref r -> r.r_global - | Pair p -> p.p_global - | Fun f -> f.f_global - -(** Return true if a type is monomorphic (global). *) -let global_tau = get_global - -let global_lvalue lv = get_global lv.contents - -(** Return true if e is a member of l (according to uref equality) *) -let rec ulist_mem e l = - match l with - | [] -> false - | h :: t -> if (U.equal(h,e)) then true else ulist_mem e t - -(** Convert a polarity to a string *) -let string_of_polarity p = - match p with - | Pos -> "+" - | Neg -> "-" - | Non -> "T" - -(** Convert a label to a string, short representation *) -let string_of_label2 (l : label) : string = - "\"" ^ (U.deref l).l_name ^ "\"" - -(** Convert a label to a string, long representation *) -let string_of_label (l : label ) : string = - let rec constset_to_string = function - | (_,s) :: [] -> s - | (_,s) :: t -> s ^ "," ^ (constset_to_string t) - | [] -> "" - in - let aliases = constset_to_string (C.elements ((U.deref l).aliases)) - in - if ( (aliases = "") || (not !verbose_debug)) - then string_of_label2 l - else aliases - -(** Return true if the element [e] is present in the association list *) -let rec assoc_list_mem (e : tau) (l : association list) = - match l with - | [] -> None - | (h,s,so) :: t -> - if (U.equal(h,e)) then (Some (s,so)) else assoc_list_mem e t - -(** Given a tau, create a unique recursive variable name. This should always - return the same name for a given tau *) -let fresh_recvar_name (t : tau) : string = - match U.deref t with - | Pair p -> "rvp" ^ string_of_int((Hashtbl.hash p)) - | Ref r -> "rvr" ^ string_of_int((Hashtbl.hash r)) - | Fun f -> "rvf" ^ string_of_int((Hashtbl.hash f)) - | _ -> raise (Inconsistent ("recvar_name")) - -(** Return a string representation of a tau, using association lists. *) -let string_of_tau (t : tau ) : string = - let tau_map : association list ref = ref [] in - let rec string_of_tau' t = - match (assoc_list_mem t (!tau_map)) with - | Some (s,so) -> (* recursive type. see if a var name has been set *) - begin - match (!so) with - | None -> - begin - let rv = fresh_recvar_name(t) in - s := "u " ^ rv ^ "." ^ (!s); - so := Some (rv); - rv - end - | Some rv -> rv - end - | None -> (* type's not recursive. Add it to the assoc list and cont. *) - let s = ref "" in - let so : string option ref = ref None in - begin - tau_map := (t,s,so) :: (!tau_map); - - (match (U.deref t) with - | Wild -> s := "_"; - | Var v -> s := v.v_name; - | Pair p -> - begin - assert (ref_or_var(p.ptr)); - assert (fun_or_var(p.lam)); - s := "{"; - s := (!s) ^ (string_of_tau' p.ptr); - s := (!s) ^ ","; - s := (!s) ^ (string_of_tau' p.lam); - s := (!s) ^"}" - - end - | Ref r -> - begin - assert(pair_or_var(r.points_to)); - s := "ref(|"; - s := (!s) ^ (string_of_label r.rl); - s := (!s) ^ "|,"; - s := (!s) ^ (string_of_tau' r.points_to); - s := (!s) ^ ")" - - end - | Fun f -> - begin - assert(pair_or_var(f.ret)); - let rec string_of_args = function - | h :: [] -> - begin - assert(pair_or_var(h)); - s := (!s) ^ (string_of_tau' h) - end - | h :: t -> - begin - assert(pair_or_var(h)); - s := (!s) ^ (string_of_tau' h) ^ ","; - string_of_args t - end - | [] -> () - in - s := "fun(|"; - s := (!s) ^ (string_of_label f.fl); - s := (!s) ^ "|,"; - s := (!s) ^ "<"; - if (List.length !(f.args) > 0) - then - string_of_args !(f.args) - else - s := (!s) ^ "void"; - s := (!s) ^">,"; - s := (!s) ^ (string_of_tau' f.ret); - s := (!s) ^ ")" - end); - tau_map := List.tl (!tau_map); - !s - end - in - string_of_tau' t - -(** Convert an lvalue to a string *) -let rec string_of_lvalue (lv : lvalue) : string = - let contents = (string_of_tau(lv.contents)) in - let l = (string_of_label lv.l) in - assert(pair_or_var(lv.contents)); - Printf.sprintf "[%s]^(%s)" contents l - -(** Print a list of tau elements, comma separated *) -let rec print_tau_list (l : tau list) : unit = - let t_strings = List.map string_of_tau l in - let rec print_t_strings = function - | h :: [] -> print_string h; print_newline(); - | h :: t -> print_string h; print_string ", "; print_t_strings t - | [] -> () - in - print_t_strings t_strings - -(** Print a constraint. *) -let print_constraint (c : su_constraint) = - match c with - | Unification (t,t') -> - let lhs = string_of_tau t in - let rhs = string_of_tau t' in - Printf.printf "%s == %s\n" lhs rhs - | Instantiation (t,(i,p),t') -> - let lhs = string_of_tau t in - let rhs = string_of_tau t' in - let index = string_of_int i in - let pol = string_of_polarity p in - Printf.printf "%s <={%s,%s} %s\n" lhs index pol rhs - -(* If [positive] is true, return the p-edge bounds, otherwise, return - the n-edge bounds. *) -let get_bounds (positive : bool) (l : label) : label boundset U.uref = - if (positive) then - (U.deref l).p_bounds - else - (U.deref l).n_bounds - -(** Used for cycle detection during the flow step. Returns true if the - label [l] is found on the current path. *) -let on_path (l : label) : bool = - (U.deref l).on_path - -(** Used for cycle detection during the flow step. Identifies [l] as being - on/off the current path. *) -let set_on_path (l : label) (b : bool) : unit = - (U.deref l).on_path <- b - -(** Make the type a global type *) -let set_global (t : tau) (b : bool) : bool = - if (!debug && b) - then - Printf.printf "Setting a new global : %s\n" (string_of_tau t); - begin - assert ( (not (get_global(t)) ) || b ); - (match U.deref t with - | Wild -> () - | Var v -> v.v_global <- b - | Ref r -> r.r_global <- b - | Pair p -> p.p_global <- b - | Fun f -> f.f_global <- b); - b - end - -(** Return a label's bounds as a string *) -let string_of_bounds (is_pos : bool) (l : label) : string = - let bounds = - if (is_pos) then - U.deref ((U.deref l).p_bounds) - else - U.deref ((U.deref l).n_bounds) - in - B.fold (fun b -> fun res -> res ^ (string_of_label2 b.info) ^ " " - ) bounds "" - -(***********************************************************************) -(* *) -(* Type Operations -- these do not create any constraints *) -(* *) -(***********************************************************************) - -let wild_val = U.uref Wild - -(** The wild (don't care) value. *) -let wild () : tau = - wild_val - -(** Create an lvalue with label [lbl] and tau contents [t]. *) -let make_lval (lbl,t : label * tau) : lvalue = - {l = lbl; contents = t} - -(** Create a new label with name [name]. Also adds a fresh constant - with name [name] to this label's aliases set. *) -let make_label (name : string) : label = - U.uref { - l_name = name; - aliases = (C.add (fresh_index(),name) C.empty); - p_bounds = U.uref (B.empty); - n_bounds = U.uref (B.empty); - p_cached = false; - n_cached = false; - on_path = false - } - -(** Create a new label with an unspecified name and an empty alias set. *) -let fresh_label () : label = - U.uref { - l_name = "l_" ^ (string_of_int (fresh_index())); - aliases = (C.empty); - p_bounds = U.uref (B.empty); - n_bounds = U.uref (B.empty); - p_cached = false; - n_cached = false; - on_path = false - } - -(** Create a fresh bound. *) -let make_bound (i,a : int * 'a) : 'a bound = - {index = i; info = a } - -(** Create a fresh named variable with name '[name]. *) -let make_var (b: bool) (name : string) : tau = - U.uref (Var {v_name = ("'" ^name); - v_global = b; - v_cache = H.create 4}) - -(** Create a fresh unnamed variable (name will be 'fv). *) -let fresh_var () : tau = - make_var false ("fv" ^ (string_of_int (fresh_index())) ) - -(** Create a fresh unnamed variable (name will be 'fi). *) -let fresh_var_i () : tau = - make_var false ("fi" ^ (string_of_int (fresh_index())) ) - -(** Create a Fun constructor. *) -let make_fun (lbl,a,r : label * (tau list) * tau) : tau = - U.uref (Fun {fl = lbl ; - f_global = false; - args = ref a; - ret = r; - f_cache = H.create 4}) - -(** Create a Ref constructor. *) -let make_ref (lbl,pt : label * tau) : tau = - U.uref (Ref {rl = lbl ; - r_global = false; - points_to = pt; - r_cache = H.create 4}) - -(** Create a Pair constructor. *) -let make_pair (p,f : tau * tau) : tau = - U.uref (Pair {ptr = p; - p_global = false; - lam = f; - p_cache = H.create 4}) - -(** Copy the toplevel constructor of [t], putting fresh variables in each - argement of the constructor. *) -let copy_toplevel (t : tau) : tau = - match U.deref t with - | Pair _ -> - make_pair (fresh_var_i(), fresh_var_i()) - | Ref _ -> - make_ref (fresh_label(),fresh_var_i()) - | Fun f -> - let fresh_fn = fun _ -> fresh_var_i() - in - make_fun (fresh_label(), List.map fresh_fn !(f.args) , fresh_var_i()) - | _ -> raise Bad_type_copy - -let pad_args (l,l' : (tau list ref) * (tau list ref)) : unit = - let padding = ref ((List.length (!l)) - (List.length (!l'))) - in - if (!padding == 0) then () - else - let to_pad = - if (!padding > 0) then l' else (padding := -(!padding);l) - in - for i = 1 to (!padding) do - to_pad := (!to_pad) @ [fresh_var()] - done - -(***********************************************************************) -(* *) -(* Constraint Generation/ Resolution *) -(* *) -(***********************************************************************) - -(** Returns true if the constraint has no effect, i.e. either the left-hand - side or the right-hand side is wild. *) -let wild_constraint (t,t' : tau * tau) : bool = - let ti,ti' = U.deref t, U.deref t' in - match ti,ti' with - | Wild, _ -> true - | _, Wild -> true - | _ -> false - -exception Cycle_found - -(** Cycle detection between instantiations. Returns true if there is a cycle - from t to t' *) -let exists_cycle (t,t' : tau * tau) : bool = - let visited : tau list ref = ref [] in - let rec exists_cycle' t = - if (ulist_mem t (!visited)) - then - begin (* - print_string "Instantiation cycle found :"; - print_tau_list (!visited); - print_newline(); - print_string (string_of_tau t); - print_newline(); *) - (* raise Instantiation_cycle *) - (* visited := List.tl (!visited) *) (* check *) - end - else - begin - visited := t :: (!visited); - if (U.equal(t,t')) - then raise Cycle_found - else - H.iter (fun _ -> fun (_,t'') -> - if (U.equal (t,t'')) then () - else - ignore (exists_cycle' t'') - ) (get_cache t) ; - visited := List.tl (!visited) - end - in - try - exists_cycle' t; - false - with - | Cycle_found -> true - -exception Subterm - -(** Returns true if [t'] is a proper subterm of [t] *) -let proper_subterm (t,t') = - let visited : tau list ref = ref [] in - let rec proper_subterm' t = - if (ulist_mem t (!visited)) - then () (* recursive type *) - else - if (U.equal (t,t')) - then raise Subterm - else - begin - visited := t :: (!visited); - ( - match (U.deref t) with - | Wild -> () - | Var _ -> () - | Ref r -> - proper_subterm' r.points_to - | Pair p -> - proper_subterm' p.ptr; - proper_subterm' p.lam - | Fun f -> - proper_subterm' f.ret; - List.iter (proper_subterm') !(f.args) - ); - visited := List.tl (!visited) - end - in - try - if (U.equal(t,t')) then false - else - begin - proper_subterm' t; - false - end - with - | Subterm -> true - -(** The extended occurs check. Search for a cycle of instantiations from [t] - to [t']. If such a cycle exists, check to see that [t'] is a proper subterm - of [t]. If it is, then return true *) -let eoc (t,t') : bool = - if (exists_cycle(t,t') && proper_subterm(t,t')) - then - begin - if (!debug) - then - Printf.printf "Occurs check : %s occurs within %s\n" (string_of_tau t') - (string_of_tau t) - else - (); - true - end - else - false - -(** Resolve an instantiation constraint *) -let rec instantiate_int (t,(i,p),t' : tau * (int * polarity) * tau) = - if ( wild_constraint(t,t') || (not (store(t,(i,p),t'))) || - U.equal(t,t') ) - then () - else - let ti,ti' = U.deref t, U.deref t' in - match ti,ti' with - | Ref r, Ref r' -> - instantiate_ref(r,(i,p),r') - | Fun f, Fun f' -> - instantiate_fun(f,(i,p),f') - | Pair pr, Pair pr' -> - begin - add_constraint_int (Instantiation (pr.ptr,(i,p),pr'.ptr)); - add_constraint_int (Instantiation (pr.lam,(i,p),pr'.lam)) - end - | Var v, _ -> () - | _,Var v' -> - if eoc(t,t') - then - add_constraint_int (Unification (t,t')) - else - begin - unstore(t,i); - add_constraint_int (Unification ((copy_toplevel t),t')); - add_constraint_int (Instantiation (t,(i,p),t')) - end - | _ -> raise (Inconsistent("instantiate")) - -(** Apply instantiations to the ref's label, and structurally down the type. - Contents of ref constructors are instantiated with polarity Non. *) -and instantiate_ref (ri,(i,p),ri') : unit = - add_constraint_int (Instantiation(ri.points_to,(i,Non),ri'.points_to)); - instantiate_label (ri.rl,(i,p),ri'.rl) - -(** Apply instantiations to the fun's label, and structurally down the type. - Flip the polarity for the function's args. If the lengths of the argument - lists don't match, extend the shorter list as necessary. *) -and instantiate_fun (fi,(i,p),fi') : unit = - pad_args (fi.args, fi'.args); - assert(List.length !(fi.args) == List.length !(fi'.args)); - add_constraint_int (Instantiation (fi.ret,(i,p),fi'.ret)); - List.iter2 (fun t ->fun t' -> - add_constraint_int (Instantiation(t,(i,negate p),t'))) - !(fi.args) !(fi'.args); - instantiate_label (fi.fl,(i,p),fi'.fl) - -(** Instantiate a label. Update the label's bounds with new flow edges. - *) -and instantiate_label (l,(i,p),l' : label * (int * polarity) * label) : unit = - if (!debug) then - Printf.printf "%s <= {%d,%s} %s\n" (string_of_label l) i - (string_of_polarity p) (string_of_label l'); - let li,li' = U.deref l, U.deref l' in - match p with - | Pos -> - U.update (li'.p_bounds, - B.add(make_bound (i,l)) (U.deref li'.p_bounds) - ) - | Neg -> - U.update (li.n_bounds, - B.add(make_bound (i,l')) (U.deref li.n_bounds) - ) - | Non -> - begin - U.update (li'.p_bounds, - B.add(make_bound (i,l)) (U.deref li'.p_bounds) - ); - U.update (li.n_bounds, - B.add(make_bound (i,l')) (U.deref li.n_bounds) - ) - end - -(** Resolve a unification constraint. Does the uref unification after grabbing - a copy of the information before the two infos are unified. The other - interesting feature of this function is the way 'globalness' is propagated. - If a non-global is unified with a global, the non-global becomes global. - If the ecr became global, there is a problem because none of its cached - instantiations know that the type became monomorphic. In this case, they - must be re-inserted via merge-cache. Merge-cache always reinserts cached - instantiations from the non-ecr type, i.e. the type that was 'killed' by the - unification. *) -and unify_int (t,t' : tau * tau) : unit = - if (wild_constraint(t,t') || U.equal(t,t')) - then () - else - let ti, ti' = U.deref t, U.deref t' in - begin - U.unify combine (t,t'); - match ti,ti' with - | Var v, _ -> - begin - if (set_global t' (v.v_global || (get_global t'))) - then (H.iter (merge_cache t') (get_cache t')) - else (); - H.iter (merge_cache t') v.v_cache - end - | _, Var v -> - begin - if (set_global t (v.v_global || (get_global t))) - then (H.iter (merge_cache t) (get_cache t)) - else (); - H.iter (merge_cache t) v.v_cache - end - | Ref r, Ref r' -> - begin - if (set_global t (r.r_global || r'.r_global)) - then (H.iter (merge_cache t) (get_cache t)) - else (); - H.iter (merge_cache t) r'.r_cache; - unify_ref(r,r') - end - | Fun f, Fun f' -> - begin - if (set_global t (f.f_global || f'.f_global)) - then (H.iter (merge_cache t) (get_cache t)) - else (); - H.iter (merge_cache t) f'.f_cache; - unify_fun (f,f'); - end - | Pair p, Pair p' -> - begin - if (set_global t (p.p_global || p'.p_global)) - then (H.iter (merge_cache t) (get_cache t)) - else (); - H.iter (merge_cache t) p'.p_cache; - add_constraint_int (Unification (p.ptr,p'.ptr)); - add_constraint_int (Unification (p.lam,p'.lam)) - end - | _ -> raise (Inconsistent("unify")) - end - -(** Unify the ref's label, and apply unification structurally down the type. *) -and unify_ref (ri,ri' : rinfo * rinfo) : unit = - add_constraint_int (Unification (ri.points_to,ri'.points_to)); - unify_label(ri.rl,ri'.rl) - -(** Unify the fun's label, and apply unification structurally down the type, - at arguments and return value. When combining two lists of different lengths, - always choose the longer list for the representative. *) -and unify_fun (li,li' : finfo * finfo) : unit = - let rec union_args = function - | _, [] -> false - | [], _ -> true - | h :: t, h' :: t' -> - add_constraint_int (Unification (h,h')); union_args(t,t') - in - begin - unify_label(li.fl,li'.fl); - add_constraint_int (Unification (li.ret,li'.ret)); - if (union_args(!(li.args),!(li'.args))) - then li.args := !(li'.args); - end - -(** Unify two labels, combining the set of constants denoting aliases. *) -and unify_label (l,l' : label * label) : unit = - let pick_name (li,li' : lblinfo * lblinfo) = - if ( (String.length li.l_name) > 1 && (String.sub (li.l_name) 0 2) = "l_") - then - li.l_name <- li'.l_name - else () - in - let combine_label (li,li' : lblinfo *lblinfo) : lblinfo = - let p_bounds = U.deref (li.p_bounds) in - let p_bounds' = U.deref (li'.p_bounds) in - let n_bounds = U.deref (li.n_bounds) in - let n_bounds' = U.deref (li'.n_bounds) in - begin - pick_name(li,li'); - li.aliases <- C.union (li.aliases) (li'.aliases); - U.update (li.p_bounds, (B.union p_bounds p_bounds')); - U.update (li.n_bounds, (B.union n_bounds n_bounds')); - li - end - in(* - if (!debug) then - begin - Printf.printf "Unifying %s with %s...\n" - (string_of_label l) (string_of_label l'); - Printf.printf "pbounds : %s\n" (string_of_bounds true l); - Printf.printf "nbounds : %s\n" (string_of_bounds false l); - Printf.printf "pbounds : %s\n" (string_of_bounds true l'); - Printf.printf "nbounds : %s\n\n" (string_of_bounds false l') - end; *) - U.unify combine_label (l,l') - (* if (!debug) then - begin - Printf.printf "pbounds : %s\n" (string_of_bounds true l); - Printf.printf "nbounds : %s\n" (string_of_bounds false l) - end *) - -(** Re-assert a cached instantiation constraint, since the old type was - killed by a unification *) -and merge_cache (rep : tau) (i : int) (p,t' : polarity * tau) : unit = - add_constraint_int (Instantiation (rep,(i,p),t')) - -(** Pick the representative info for two tinfo's. This function prefers the - first argument when both arguments are the same structure, but when - one type is a structure and the other is a var, it picks the structure. *) -and combine (ti,ti' : tinfo * tinfo) : tinfo = - match ti,ti' with - | Var _, _ -> ti' - | _,_ -> ti - -(** Add a new constraint induced by other constraints. *) -and add_constraint_int (c : su_constraint) = - if (!print_constraints && !debug) then print_constraint c else (); - begin - match c with - | Instantiation _ -> - Q.add c inst_worklist - | Unification _ -> - Q.add c eq_worklist - end; - if (!debug) then solve_constraints() else () - -(** Add a new constraint introduced through this module's interface (a - top-level constraint). *) -and add_constraint (c : su_constraint) = - begin - add_constraint_int (c); - if (!print_constraints && not (!debug)) then print_constraint c else (); - if (!solve_online) then solve_constraints() else () - end - - -(* Fetch constraints, preferring equalities. *) -and fetch_constraint () : su_constraint option = - if (Q.length eq_worklist > 0) - then - Some (Q.take eq_worklist) - else if (Q.length inst_worklist > 0) - then - Some (Q.take inst_worklist) - else - None - -(** Returns the target of a cached instantiation, if it exists. *) -and target (t,i,p : tau * int * polarity) : (polarity * tau) option = - let cache = get_cache t in - if (global_tau t) then Some (Non,t) - else - try - Some (H.find cache i) - with - | Not_found -> None - -(** Caches a new instantiation, or applies well-formedness. *) -and store ( t,(i,p),t' : tau * (int * polarity) * tau) : bool = - let cache = get_cache t in - match target(t,i,p) with - | Some (p'',t'') -> - if (U.equal (t',t'') && (lub(p,p'') = p'')) - then - false - else - begin - add_constraint_int (Unification (t',t'')); - H.replace cache i (lub(p,p''),t''); - (* add a new forced instantiation as well *) - if (lub(p,p'') = p'') - then () - else - begin - unstore(t,i); - add_constraint_int (Instantiation (t,(i,lub(p,p'')),t'')) - end; - false - end - | None -> - begin - H.add cache i (p,t'); - true - end - -(** Remove a cached instantiation. Used when type structure changes *) -and unstore (t,i : tau * int) = -let cache = get_cache t in - H.remove cache i - -(** The main solver loop. *) -and solve_constraints () : unit = - match fetch_constraint () with - | Some c -> - begin - (match c with - | Instantiation (t,(i,p),t') -> instantiate_int (t,(i,p),t') - | Unification (t,t') -> unify_int (t,t') - ); - solve_constraints() - end - | None -> () - - -(***********************************************************************) -(* *) -(* Interface Functions *) -(* *) -(***********************************************************************) - -(** Return the contents of the lvalue. *) -let rvalue (lv : lvalue) : tau = - lv.contents - -(** Dereference the rvalue. If it does not have enough structure to support - the operation, then the correct structure is added via new unification - constraints. *) -let rec deref (t : tau) : lvalue = - match U.deref t with - | Pair p -> - ( - match U.deref (p.ptr) with - | Var _ -> - begin - (* let points_to = make_pair(fresh_var(),fresh_var()) in *) - let points_to = fresh_var() in - let l = fresh_label() in - let r = make_ref(l,points_to) - in - add_constraint (Unification (p.ptr,r)); - make_lval(l, points_to) - end - | Ref r -> make_lval(r.rl, r.points_to) - | _ -> raise (Inconsistent("deref")) - ) - | Var v -> - begin - add_constraint (Unification (t,make_pair(fresh_var(),fresh_var()))); - deref t - end - | _ -> raise (Inconsistent("deref -- no top level pair")) - -(** Form the union of [t] and [t']. *) -let join (t : tau) (t' : tau) : tau = - let t'' = fresh_var() in - add_constraint (Unification (t,t'')); - add_constraint (Unification (t',t'')); - t'' - -(** Form the union of a list [tl], expected to be the initializers of some - structure or array type. *) -let join_inits (tl : tau list) : tau = - let t' = fresh_var() in - begin - List.iter (function t'' -> add_constraint (Unification(t',t''))) tl; - t' - end - -(** Take the address of an lvalue. Does not add constraints. *) -let address (lv : lvalue) : tau = - make_pair (make_ref (lv.l, lv.contents), fresh_var() ) - -(** Instantiate a type with index i. By default, uses positive polarity. - Adds an instantiation constraint. *) -let instantiate (lv : lvalue) (i : int) : lvalue = - if (!analyze_mono) then lv - else - begin - let l' = fresh_label () in - let t' = fresh_var_i () in - instantiate_label(lv.l,(i,Pos),l'); - add_constraint (Instantiation (lv.contents,(i,Pos),t')); - make_lval(l',t') (* check -- fresh label ?? *) - end - -(** Constraint generated from assigning [t] to [lv]. *) -let assign (lv : lvalue) (t : tau) : unit = - add_constraint (Unification (lv.contents,t)) - - -(** Project out the first (ref) component or a pair. If the argument [t] has - no discovered structure, raise No_contents. *) -let proj_ref (t : tau) : tau = - match U.deref t with - | Pair p -> p.ptr - | Var v -> raise No_contents - | _ -> raise Bad_proj - -(* Project out the second (fun) component of a pair. If the argument [t] has - no discovered structure, create it on the fly by adding constraints. *) -let proj_fun (t : tau) : tau = - match U.deref t with - | Pair p -> p.lam - | Var v -> - let p,f = fresh_var(), fresh_var() in - add_constraint (Unification (t,make_pair(p,f))); - f - | _ -> raise Bad_proj - -let get_args (t : tau) : tau list ref = - match U.deref t with - | Fun f -> f.args - | _ -> raise (Inconsistent("get_args")) - -(** Function type [t] is applied to the arguments [actuals]. Unifies the - actuals with the formals of [t]. If no functions have been discovered for - [t] yet, create a fresh one and unify it with t. The result is the return - value of the function. *) -let apply (t : tau) (al : tau list) : tau = - let f = proj_fun(t) in - let actuals = ref al in - let formals,ret = - match U.deref f with - | Fun fi -> (fi.args),fi.ret - | Var v -> - let new_l,new_ret,new_args = - fresh_label(), fresh_var (), - List.map (function _ -> fresh_var()) (!actuals) - in - let new_fun = make_fun(new_l,new_args,new_ret) in - add_constraint (Unification(new_fun,f)); - (get_args new_fun,new_ret) - | Ref _ -> raise (Inconsistent ("apply_ref")) - | Pair _ -> raise (Inconsistent ("apply_pair")) - | Wild -> raise (Inconsistent("apply_wild")) - in - pad_args(formals,actuals); - List.iter2 (fun actual -> fun formal -> - add_constraint (Unification (actual,formal)) - ) !actuals !formals; - ret - -(** Create a new function type with name [name], list of formal arguments - [formals], and return value [ret]. Adds no constraints. *) -let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = - let - f = make_fun(make_label(name),List.map (fun x -> rvalue x) formals, ret) - in - make_pair(fresh_var(),f) - -(** Create an lvalue. If [is_global] is true, the lvalue will be treated - monomorphically. *) -let make_lvalue (is_global : bool) (name : string) : lvalue = - if (!debug && is_global) - then - Printf.printf "Making global lvalue : %s\n" name - else (); - make_lval(make_label(name), make_var is_global name) - - -(** Create a fresh non-global named variable. *) -let make_fresh (name : string) : tau = - make_var false (name) - -(** The default type for constants. *) -let bottom () : tau = - make_var false ("bottom") - -(** Unify the result of a function with its return value. *) -let return (t : tau) (t' : tau) = - add_constraint (Unification (t,t')) - - -(***********************************************************************) -(* *) -(* Query/Extract Solutions *) -(* *) -(***********************************************************************) - -(** Unify the data stored in two label bounds. *) -let combine_lbounds (s,s' : label boundset * label boundset) = - B.union s s' - -(** Truncates a list of urefs [l] to those elements up to and including the - first occurence of the specified element [elt]. *) -let truncate l elt = - let keep = ref true in - List.filter - (fun x -> - if (not (!keep)) - then - false - else - begin - if (U.equal(x,elt)) - then - keep := false - else (); - true - end - ) l - -let debug_cycle_bounds is_pos c = - let rec debug_cycle_bounds' = function - | h :: [] -> - Printf.printf "%s --> %s\n" (string_of_bounds is_pos h) - (string_of_label2 h) - | h :: t -> - begin - Printf.printf "%s --> %s\n" (string_of_bounds is_pos h) - (string_of_label2 h); - debug_cycle_bounds' t - end - | [] -> () - in - debug_cycle_bounds' c - -(** For debugging, print a cycle of instantiations *) -let debug_cycle (is_pos,c,l,p) = - let kind = if is_pos then "P" else "N" in - let rec string_of_cycle = function - | h :: [] -> string_of_label2 h - | [] -> "" - | h :: t -> Printf.sprintf "%s,%s" (string_of_label2 h) (string_of_cycle t) - in - Printf.printf "Collapsing %s cycle around %s:\n" kind (string_of_label2 l); - Printf.printf "Elements are: %s\n" (string_of_cycle c); - Printf.printf "Per-element bounds:\n"; - debug_cycle_bounds is_pos c; - Printf.printf "Full path is: %s" (string_of_cycle p); - print_newline() - -(** Compute pos or neg flow, depending on [is_pos]. Searches for cycles in the - instantiations (can these even occur?) and unifies either the positive or - negative edge sets for the labels on the cycle. Note that this does not - ever unify the labels themselves. The return is the new bounds of the - argument label *) -let rec flow (is_pos : bool) (path : label list) (l : label) : label boundset = - let collapse_cycle () = - let cycle = truncate path l in - debug_cycle (is_pos,cycle,l,path); - List.iter (fun x -> U.unify combine_lbounds - ((get_bounds is_pos x),get_bounds is_pos l) - ) cycle - in - if (on_path l) - then - begin - collapse_cycle (); - (* set_on_path l false; *) - B.empty - end - else - if ( (is_pos && (U.deref l).p_cached) || - ( (not is_pos) && (U.deref l).n_cached) ) then - begin - U.deref (get_bounds is_pos l) - end - else - begin - let newbounds = ref B.empty in - let base = get_bounds is_pos l in - set_on_path l true; - if (is_pos) then - (U.deref l).p_cached <- true - else - (U.deref l).n_cached <- true; - B.iter - (fun x -> - if (U.equal(x.info,l)) then () - else - (newbounds := - (B.union (!newbounds) (flow is_pos (l :: path) x.info))) - ) (U.deref base); - set_on_path l false; - U.update (base,(B.union (U.deref base) !newbounds)); - U.deref base - end - -(** Compute and cache any positive flow. *) -let pos_flow l : constantset = - let result = ref C.empty in - begin - ignore (flow true [] l); - B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases ) - (U.deref (get_bounds true l)); - !result - end - -(** Compute and cache any negative flow. *) -let neg_flow l : constantset = - let result = ref C.empty in - begin - ignore (flow false [] l); - B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases ) - (U.deref (get_bounds false l)); - !result - end - -(** Compute and cache any pos-neg flow. Assumes that both pos_flow and - neg_flow have been computed for the label [l]. *) -let pos_neg_flow(l : label) : constantset = - let result = ref C.empty in - begin - B.iter (fun x -> result := C.union (!result) (pos_flow x.info)) - (U.deref (get_bounds false l)); - !result - end - -(** Compute a points-to set by computing positive, then negative, then - positive-negative flow for a label. *) -let points_to_int (lv : lvalue) : constantset = - let visited_caches : cache list ref = ref [] in - let rec points_to_tau (t : tau) : constantset = - try - begin - match U.deref (proj_ref t) with - | Var v -> C.empty - | Ref r -> - begin - let pos = pos_flow r.rl in - let neg = neg_flow r.rl in - let interproc = C.union (pos_neg_flow r.rl) (C.union pos neg) - in - C.union ((U.deref(r.rl)).aliases) interproc - end - | _ -> raise (Inconsistent ("points_to")) - end - with - | No_contents -> - begin - match (U.deref t) with - | Var v -> rebuild_flow v.v_cache - | _ -> raise (Inconsistent ("points_to")) - end - and rebuild_flow (c : cache) : constantset = - if (List.mem c (!visited_caches) ) (* cyclic instantiations *) - then - begin - (* visited_caches := List.tl (!visited_caches); *) (* check *) - C.empty - end - else - begin - visited_caches := c :: (!visited_caches); - let result = ref (C.empty) in - H.iter (fun _ -> fun(p,t) -> - match p with - | Pos -> () - | _ -> result := C.union (!result) (points_to_tau t) - ) c; - visited_caches := List.tl (!visited_caches); - !result - end - in - if (!no_flow) then - (U.deref lv.l).aliases - else - points_to_tau (lv.contents) - -let points_to (lv : lvalue) : string list = - List.map snd (C.elements (points_to_int lv)) - -let alias_query (a_progress : bool) (lv : lvalue list) : int * int = - (0,0) (* todo *) -(* - let a_count = ref 0 in - let ptsets = List.map points_to_int lv in - let total_sets = List.length ptsets in - let counted_sets = ref 0 in - let record_alias s s' = - if (C.is_empty (C.inter s s')) - then () - else (incr a_count) - in - let rec check_alias = function - | h :: t -> - begin - List.iter (record_alias h) ptsets; - check_alias t - end - | [] -> () - in - check_alias ptsets; - !a_count -*) diff --git a/cil/src/ext/pta/steensgaard.mli b/cil/src/ext/pta/steensgaard.mli deleted file mode 100644 index f009e7e..0000000 --- a/cil/src/ext/pta/steensgaard.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(***********************************************************************) -(* *) -(* *) -(* This file is currently unused by CIL. It is included in the *) -(* distribution for reference only. *) -(* *) -(* *) -(***********************************************************************) - -type lvalue -type tau -val debug : bool ref -val debug_constraints : bool ref -val print_constraints : bool ref -val no_flow : bool ref -val no_sub : bool ref -val analyze_mono : bool ref -val solve_online : bool ref -val solve_constraints : unit -> unit -val rvalue : lvalue -> tau -val deref : tau -> lvalue -val join : tau -> tau -> tau -val join_inits : tau list -> tau -val address : lvalue -> tau -val instantiate : lvalue -> int -> lvalue -val assign : lvalue -> tau -> unit -val apply : tau -> tau list -> tau -val make_function : string -> lvalue list -> tau -> tau -val make_lvalue : bool -> string -> lvalue -val bottom : unit -> tau -val return : tau -> tau -> unit -val make_fresh : string -> tau -val points_to : lvalue -> string list -val string_of_lvalue : lvalue -> string -val global_lvalue : lvalue -> bool -val alias_query : bool -> lvalue list -> int * int diff --git a/cil/src/ext/pta/uref.ml b/cil/src/ext/pta/uref.ml deleted file mode 100644 index 53f3640..0000000 --- a/cil/src/ext/pta/uref.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -exception Bad_find - -type 'a urefC = - Ecr of 'a * int - | Link of 'a uref -and 'a uref = 'a urefC ref - -let rec find p = - match !p with - | Ecr _ -> p - | Link p' -> - let p'' = find p' - in p := Link p''; p'' - -let uref x = ref (Ecr(x,0)) - -let equal (p,p') = (find p == find p') - -let deref p = - match ! (find p) with - | Ecr (x,_) -> x - | _ -> raise Bad_find - -let update (p,x) = - let p' = find p - in - match !p' with - | Ecr (_,rank) -> p' := Ecr(x,rank) - | _ -> raise Bad_find - -let unify f (p,q) = - let p',q' = find p, find q in - match (!p',!q') with - | (Ecr(px,pr),Ecr(qx,qr)) -> - let x = f(px,qx) in - if (p' == q') then - p' := Ecr(x,pr) - else if pr == qr then - (q' := Ecr(x,qr+1); p' := Link q') - else if pr < qr then - (q' := Ecr(x,qr); p' := Link q') - else (* pr > qr *) - (p' := Ecr(x,pr); q' := Link p') - | _ -> raise Bad_find - -let union (p,q) = - let p',q' = find p, find q in - match (!p',!q') with - | (Ecr(px,pr),Ecr(qx,qr)) -> - if (p' == q') then - () - else if pr == qr then - (q' := Ecr(qx, qr+1); p' := Link q') - else if pr < qr then - p' := Link q' - else (* pr > qr *) - q' := Link p' - | _ -> raise Bad_find - - diff --git a/cil/src/ext/pta/uref.mli b/cil/src/ext/pta/uref.mli deleted file mode 100644 index 1dee503..0000000 --- a/cil/src/ext/pta/uref.mli +++ /dev/null @@ -1,65 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * John Kodumal - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -type 'a uref - -(** Union-find with union by rank and path compression - - This is an implementation of Tarjan's union-find data structure using - generics. The interface is analagous to standard references, with the - addition of a union operation which makes two references indistinguishable. - -*) - -val uref: 'a -> 'a uref - (** Create a new uref *) - -val equal: 'a uref * 'a uref -> bool - (** Test whether two urefs share the same equivalence class *) - -val deref: 'a uref -> 'a - (** Extract the contents of this reference *) - -val update: 'a uref * 'a -> unit - (** Update the value stored in this reference *) - -val unify: ('a * 'a -> 'a) -> 'a uref * 'a uref -> unit - (** [unify f (p,q)] unifies references [p] and [q], making them - indistinguishable. The contents of the reference are the result of - [f] *) - -val union: 'a uref * 'a uref -> unit - (** [unify (p,q)] unifies references [p] and [q], making them - indistinguishable. The contents of the reference are the contents of - one of the first or second arguments (unspecified) *) diff --git a/cil/src/ext/reachingdefs.ml b/cil/src/ext/reachingdefs.ml deleted file mode 100644 index b6af37c..0000000 --- a/cil/src/ext/reachingdefs.ml +++ /dev/null @@ -1,511 +0,0 @@ -(* Calculate reaching definitions for each instruction. - * Determine when it is okay to replace some variables with - * expressions. - * - * After calling computeRDs on a fundec, - * ReachingDef.stmtStartData will contain a mapping from - * statement ids to data about which definitions reach each - * statement. ReachingDef.defIdStmtHash will contain a - * mapping from definition ids to the statement in which - * that definition takes place. - * - * instrRDs takes a list of instructions, and the - * definitions that reach the first instruction, and - * for each instruction figures out which definitions - * reach into or out of each instruction. - * - *) - -open Cil -open Pretty - -module E = Errormsg -module DF = Dataflow -module UD = Usedef -module IH = Inthash -module U = Util -module S = Stats - -let debug_fn = ref "" - -module IOS = - Set.Make(struct - type t = int option - let compare io1 io2 = - match io1, io2 with - Some i1, Some i2 -> Pervasives.compare i1 i2 - | Some i1, None -> 1 - | None, Some i2 -> -1 - | None, None -> 0 - end) - -let debug = ref false - -(* return the intersection of - Inthashes ih1 and ih2 *) -let ih_inter ih1 ih2 = - let ih' = IH.copy ih1 in - IH.iter (fun id vi -> - if not(IH.mem ih2 id) then - IH.remove ih' id else - ()) ih1; - ih' - -let ih_union ih1 ih2 = - let ih' = IH.copy ih1 in - IH.iter (fun id vi -> - if not(IH.mem ih' id) - then IH.add ih' id vi - else ()) ih2; - ih' - -(* Lookup varinfo in iosh. If the set contains None - or is not a singleton, return None, otherwise - return Some of the singleton *) -(* IOS.t IH.t -> varinfo -> int option *) -let iosh_singleton_lookup iosh vi = - if IH.mem iosh vi.vid then - let ios = IH.find iosh vi.vid in - if not (IOS.cardinal ios = 1) then None - else IOS.choose ios - else None - -(* IOS.t IH.t -> varinfo -> IOS.t *) -let iosh_lookup iosh vi = - if IH.mem iosh vi.vid - then Some(IH.find iosh vi.vid) - else None - -(* return Some(vid) if iosh contains defId. - return None otherwise *) -(* IOS.t IH.t -> int -> int option *) -let iosh_defId_find iosh defId = - (* int -> IOS.t -> int option -> int option*) - let get_vid vid ios io = - match io with - Some(i) -> Some(i) - | None -> - let there = IOS.exists - (function None -> false - | Some(i') -> defId = i') ios in - if there then Some(vid) else None - in - IH.fold get_vid iosh None - -(* The resulting iosh will contain the - union of the same entries from iosh1 and - iosh2. If iosh1 has an entry that iosh2 - does not, then the result will contain - None in addition to the things from the - entry in iosh1. *) -(* XXX this function is a performance bottleneck *) -let iosh_combine iosh1 iosh2 = - let iosh' = IH.copy iosh1 in - IH.iter (fun id ios1 -> - try let ios2 = IH.find iosh2 id in - let newset = IOS.union ios1 ios2 in - IH.replace iosh' id newset; - with Not_found -> - let newset = IOS.add None ios1 in - IH.replace iosh' id newset) iosh1; - IH.iter (fun id ios2 -> - if not(IH.mem iosh1 id) then - let newset = IOS.add None ios2 in - IH.add iosh' id newset) iosh2; - iosh' - - -(* determine if two IOS.t IH.t s are the same *) -let iosh_equals iosh1 iosh2 = -(* if IH.length iosh1 = 0 && not(IH.length iosh2 = 0) || - IH.length iosh2 = 0 && not(IH.length iosh1 = 0)*) - if not(IH.length iosh1 = IH.length iosh2) - then - (if !debug then ignore(E.log "iosh_equals: length not same\n"); - false) - else - IH.fold (fun vid ios b -> - if not b then b else - try let ios2 = IH.find iosh2 vid in - if not(IOS.compare ios ios2 = 0) then - (if !debug then ignore(E.log "iosh_equals: sets for vid %d not equal\n" vid); - false) - else true - with Not_found -> - (if !debug then ignore(E.log "iosh_equals: vid %d not in iosh2\n" vid); - false)) iosh1 true - -(* replace an entire set with a singleton. - if nothing was there just add the singleton *) -(* IOS.t IH.t -> int -> varinfo -> unit *) -let iosh_replace iosh i vi = - if IH.mem iosh vi.vid then - let newset = IOS.singleton (Some i) in - IH.replace iosh vi.vid newset - else - let newset = IOS.singleton (Some i) in - IH.add iosh vi.vid newset - -(* remove definitions that are killed. - add definitions that are gend *) -(* Takes the defs, the data, and a function for - obtaining the next def id *) -(* VS.t -> IOS.t IH.t -> (unit->int) -> unit *) -let proc_defs vs iosh f = - let pd vi = - let newi = f() in - (*if !debug then - ignore (E.log "proc_defs: genning %d\n" newi);*) - iosh_replace iosh newi vi - in - UD.VS.iter pd vs - -let idMaker () start = - let counter = ref start in - fun () -> - let ret = !counter in - counter := !counter + 1; - ret - -(* given reaching definitions into a list of - instructions, figure out the definitions that - reach in/out of each instruction *) -(* if out is true then calculate the definitions that - go out of each instruction, if it is false then - calculate the definitions reaching into each instruction *) -(* instr list -> int -> (varinfo IH.t * int) -> bool -> (varinfo IH.t * int) list *) -let iRDsHtbl = Hashtbl.create 128 -let instrRDs il sid (ivih, s, iosh) out = - if Hashtbl.mem iRDsHtbl (sid,out) then Hashtbl.find iRDsHtbl (sid,out) else - -(* let print_instr i (_,s', iosh') = *) -(* let d = d_instr () i ++ line in *) -(* fprint stdout 80 d; *) -(* flush stdout *) -(* in *) - - let proc_one hil i = - match hil with - | [] -> - let _, defd = UD.computeUseDefInstr i in - if UD.VS.is_empty defd - then ((*if !debug then print_instr i ((), s, iosh);*) - [((), s, iosh)]) - else - let iosh' = IH.copy iosh in - proc_defs defd iosh' (idMaker () s); - (*if !debug then - print_instr i ((), s + UD.VS.cardinal defd, iosh');*) - ((), s + UD.VS.cardinal defd, iosh')::hil - | (_, s', iosh')::hrst as l -> - let _, defd = UD.computeUseDefInstr i in - if UD.VS.is_empty defd - then - ((*if !debug then - print_instr i ((),s', iosh');*) - ((), s', iosh')::l) - else let iosh'' = IH.copy iosh' in - proc_defs defd iosh'' (idMaker () s'); - (*if !debug then - print_instr i ((), s' + UD.VS.cardinal defd, iosh'');*) - ((),s' + UD.VS.cardinal defd, iosh'')::l - in - let folded = List.fold_left proc_one [((),s,iosh)] il in - let foldedout = List.tl (List.rev folded) in - let foldednotout = List.rev (List.tl folded) in - Hashtbl.add iRDsHtbl (sid,true) foldedout; - Hashtbl.add iRDsHtbl (sid,false) foldednotout; - if out then foldedout else foldednotout - - - -(* The right hand side of an assignment is either - a function call or an expression *) -type rhs = RDExp of exp | RDCall of instr - -(* take the id number of a definition and return - the rhs of the definition if there is one. - Returns None if, for example, the definition is - caused by an assembly instruction *) -(* stmt IH.t -> (()*int*IOS.t IH.t) IH.t -> int -> (rhs * int * IOS.t IH.t) option *) -let rhsHtbl = IH.create 64 (* to avoid recomputation *) -let getDefRhs didstmh stmdat defId = - if IH.mem rhsHtbl defId then IH.find rhsHtbl defId else - let stm = - try IH.find didstmh defId - with Not_found -> E.s (E.error "getDefRhs: defId %d not found\n" defId) in - let (_,s,iosh) = - try IH.find stmdat stm.sid - with Not_found -> E.s (E.error "getDefRhs: sid %d not found \n" stm.sid) in - match stm.skind with - Instr il -> - let ivihl = instrRDs il stm.sid ((),s,iosh) true in (* defs that reach out of each instr *) - let ivihl_in = instrRDs il stm.sid ((),s,iosh) false in (* defs that reach into each instr *) - let iihl = List.combine (List.combine il ivihl) ivihl_in in - (try let ((i,(_,_,diosh)),(_,_,iosh_in)) = List.find (fun ((i,(_,_,iosh')),_) -> - match S.time "iosh_defId_find" (iosh_defId_find iosh') defId with - Some vid -> - (match i with - Set((Var vi',NoOffset),_,_) -> vi'.vid = vid (* _ -> NoOffset *) - | Call(Some(Var vi',NoOffset),_,_,_) -> vi'.vid = vid (* _ -> NoOffset *) - | Call(None,_,_,_) -> false - | Asm(_,_,sll,_,_,_) -> List.exists - (function (_,(Var vi',NoOffset)) -> vi'.vid = vid | _ -> false) sll - | _ -> false) - | None -> false) iihl in - (match i with - Set((lh,_),e,_) -> - (match lh with - Var(vi') -> - (IH.add rhsHtbl defId (Some(RDExp(e),stm.sid,iosh_in)); - Some(RDExp(e), stm.sid, iosh_in)) - | _ -> E.s (E.error "Reaching Defs getDefRhs: right vi not first\n")) - | Call(lvo,e,el,_) -> - (IH.add rhsHtbl defId (Some(RDCall(i),stm.sid,iosh_in)); - Some(RDCall(i), stm.sid, iosh_in)) - | Asm(a,sl,slvl,sel,sl',_) -> None) (* ? *) - with Not_found -> - (if !debug then ignore (E.log "getDefRhs: No instruction defines %d\n" defId); - IH.add rhsHtbl defId None; - None)) - | _ -> E.s (E.error "getDefRhs: defining statement not an instruction list %d\n" defId) - (*None*) - -let prettyprint didstmh stmdat () (_,s,iosh) = text "" - (*seq line (fun (vid,ios) -> - num vid ++ text ": " ++ - IOS.fold (fun io d -> match io with - None -> d ++ text "None " - | Some i -> - let stm = IH.find didstmh i in - match getDefRhs didstmh stmdat i with - None -> d ++ num i - | Some(RDExp(e),_,_) -> - d ++ num i ++ text " " ++ (d_exp () e) - | Some(RDCall(c),_,_) -> - d ++ num i ++ text " " ++ (d_instr () c)) - ios nil) - (IH.tolist iosh)*) - -module ReachingDef = - struct - - let name = "Reaching Definitions" - - let debug = debug - - (* Should the analysis calculate may-reach - or must-reach *) - let mayReach = ref false - - - (* An integer that tells the id number of - the first definition *) - (* Also a hash from variable ids to a set of - definition ids that reach this statement. - None means there is a path to this point on which - there is no definition of the variable *) - type t = (unit * int * IOS.t IH.t) - - let copy (_, i, iosh) = ((), i, IH.copy iosh) - - (* entries for starting statements must - be added before calling compute *) - let stmtStartData = IH.create 32 - - (* a mapping from definition ids to - the statement corresponding to that id *) - let defIdStmtHash = IH.create 32 - - (* mapping from statement ids to statements - for better performance of ok_to_replace *) - let sidStmtHash = IH.create 64 - - (* pretty printer *) - let pretty = prettyprint defIdStmtHash stmtStartData - - - (* The first id to use when computeFirstPredecessor - is next called *) - let nextDefId = ref 0 - - (* Count the number of variable definitions in - a statement *) - let num_defs stm = - match stm.skind with - Instr(il) -> List.fold_left (fun s i -> - let _, d = UD.computeUseDefInstr i in - s + UD.VS.cardinal d) 0 il - | _ -> let _, d = UD.computeUseDefStmtKind stm.skind in - UD.VS.cardinal d - - (* the first predecessor is just the data in along with - the id of the first definition of the statement, - which we get from nextDefId *) - let computeFirstPredecessor stm (_, s, iosh) = - let startDefId = max !nextDefId s in - let numds = num_defs stm in - let rec loop n = - if n < 0 - then () - else - (if !debug then - ignore (E.log "RD: defId %d -> stm %d\n" (startDefId + n) stm.sid); - IH.add defIdStmtHash (startDefId + n) stm; - loop (n-1)) - in - loop (numds - 1); - nextDefId := startDefId + numds; - ((), startDefId, IH.copy iosh) - - - let combinePredecessors (stm:stmt) ~(old:t) ((_, s, iosh):t) = - match old with (_, os, oiosh) -> - if S.time "iosh_equals" (iosh_equals oiosh) iosh then None else - Some((), os, S.time "iosh_combine" (iosh_combine oiosh) iosh) - - (* return an action that removes things that - are redefinied and adds the generated defs *) - let doInstr inst (_, s, iosh) = - let transform (_, s', iosh') = - let _, defd = UD.computeUseDefInstr inst in - proc_defs defd iosh' (idMaker () s'); - ((), s' + UD.VS.cardinal defd, iosh') - in - DF.Post transform - - (* all the work gets done at the instruction level *) - let doStmt stm (_, s, iosh) = - if not(IH.mem sidStmtHash stm.sid) then - IH.add sidStmtHash stm.sid stm; - if !debug then ignore(E.log "RD: looking at %a\n" d_stmt stm); - DF.SDefault - - let doGuard condition _ = DF.GDefault - - let filterStmt stm = true - -end - -module RD = DF.ForwardsDataFlow(ReachingDef) - -(* map all variables in vil to a set containing - None in iosh *) -(* IOS.t IH.t -> varinfo list -> () *) -let iosh_none_fill iosh vil = - List.iter (fun vi -> - IH.add iosh vi.vid (IOS.singleton None)) - vil - -(* Computes the reaching definitions for a - function. *) -(* Cil.fundec -> unit *) -let computeRDs fdec = - try - if compare fdec.svar.vname (!debug_fn) = 0 then - (debug := true; - ignore (E.log "%s =\n%a\n" (!debug_fn) d_block fdec.sbody)); - let bdy = fdec.sbody in - let slst = bdy.bstmts in - let _ = IH.clear ReachingDef.stmtStartData in - let _ = IH.clear ReachingDef.defIdStmtHash in - let _ = IH.clear rhsHtbl in - let _ = Hashtbl.clear iRDsHtbl in - let _ = ReachingDef.nextDefId := 0 in - let fst_stm = List.hd slst in - let fst_iosh = IH.create 32 in - let _ = UD.onlyNoOffsetsAreDefs := false in - (*let _ = iosh_none_fill fst_iosh fdec.sformals in*) - let _ = IH.add ReachingDef.stmtStartData fst_stm.sid ((), 0, fst_iosh) in - let _ = ReachingDef.computeFirstPredecessor fst_stm ((), 0, fst_iosh) in - if !debug then - ignore (E.log "computeRDs: fst_stm.sid=%d\n" fst_stm.sid); - RD.compute [fst_stm]; - if compare fdec.svar.vname (!debug_fn) = 0 then - debug := false - (* now ReachingDef.stmtStartData has the reaching def data in it *) - with Failure "hd" -> if compare fdec.svar.vname (!debug_fn) = 0 then - debug := false - -(* return the definitions that reach the statement - with statement id sid *) -let getRDs sid = - try - Some (IH.find ReachingDef.stmtStartData sid) - with Not_found -> - None -(* E.s (E.error "getRDs: sid %d not found\n" sid) *) - -let getDefIdStmt defid = - try - Some(IH.find ReachingDef.defIdStmtHash defid) - with Not_found -> - None - -let getStmt sid = - try Some(IH.find ReachingDef.sidStmtHash sid) - with Not_found -> None - -(* Pretty print the reaching definition data for - a function *) -let ppFdec fdec = - seq line (fun stm -> - let ivih = IH.find ReachingDef.stmtStartData stm.sid in - ReachingDef.pretty () ivih) fdec.sbody.bstmts - - -(* If this class is extended with a visitor on expressions, - then the current rd data is available at each expression *) -class rdVisitorClass = object (self) - inherit nopCilVisitor - - (* the statement being worked on *) - val mutable sid = -1 - - (* if a list of instructions is being processed, - then this is the corresponding list of - reaching definitions *) - val mutable rd_dat_lst = [] - - (* these are the reaching defs for the current - instruction if there is one *) - val mutable cur_rd_dat = None - - method vstmt stm = - sid <- stm.sid; - match getRDs sid with - None -> - if !debug then ignore(E.log "rdVis: stm %d had no data\n" sid); - cur_rd_dat <- None; - DoChildren - | Some(_,s,iosh) -> - match stm.skind with - Instr il -> - if !debug then ignore(E.log "rdVis: visit il\n"); - rd_dat_lst <- instrRDs il stm.sid ((),s,iosh) false; - DoChildren - | _ -> - if !debug then ignore(E.log "rdVis: visit non-il\n"); - cur_rd_dat <- None; - DoChildren - - method vinst i = - if !debug then ignore(E.log "rdVis: before %a, rd_dat_lst is %d long\n" - d_instr i (List.length rd_dat_lst)); - try - cur_rd_dat <- Some(List.hd rd_dat_lst); - rd_dat_lst <- List.tl rd_dat_lst; - DoChildren - with Failure "hd" -> - if !debug then ignore(E.log "rdVis: il rd_dat_lst mismatch\n"); - DoChildren - - method get_cur_iosh () = - match cur_rd_dat with - None -> (match getRDs sid with - None -> None - | Some(_,_,iosh) -> Some iosh) - | Some(_,_,iosh) -> Some iosh - -end - diff --git a/cil/src/ext/sfi.ml b/cil/src/ext/sfi.ml deleted file mode 100755 index 9886526..0000000 --- a/cil/src/ext/sfi.ml +++ /dev/null @@ -1,337 +0,0 @@ -(* - * - * Copyright (c) 2005, - * George C. Necula - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** This is a module that inserts runtime checks for memory reads/writes and - * allocations *) - -open Pretty -open Cil -module E = Errormsg -module H = Hashtbl - -let doSfi = ref false -let doSfiReads = ref false -let doSfiWrites = ref true - -(* A number of functions to be skipped *) -let skipFunctions : (string, unit) H.t = H.create 13 -let mustSfiFunction (f: fundec) : bool = - not (H.mem skipFunctions f.svar.vname) - -(** Some functions are known to be allocators *) -type dataLocation = - InResult (* Interesting data is in the return value *) - | InArg of int (* in the nth argument. Starts from 1. *) - | InArgTimesArg of int * int (* (for size) data is the product of two - * arguments *) - | PointedToByArg of int (* pointed to by nth argument *) - -(** Compute the data based on the location and the actual argument list *) -let extractData (dl: dataLocation) (args: exp list) (res: lval option) : exp = - let getArg (n: int) = - try List.nth args (n - 1) (* Args are based at 1 *) - with _ -> E.s (E.bug "Cannot extract argument %d at %a" - n d_loc !currentLoc) - in - match dl with - InResult -> begin - match res with - None -> - E.s (E.bug "Cannot extract InResult data (at %a)" d_loc !currentLoc) - | Some r -> Lval r - end - | InArg n -> getArg n - | InArgTimesArg (n1, n2) -> - let a1 = getArg n1 in - let a2 = getArg n2 in - BinOp(Mult, mkCast ~e:a1 ~newt:longType, - mkCast ~e:a2 ~newt:longType, longType) - | PointedToByArg n -> - let a = getArg n in - Lval (mkMem a NoOffset) - - - -(* for each allocator, where is the length and where is the result *) -let allocators: (string, (dataLocation * dataLocation)) H.t = H.create 13 -let _ = - H.add allocators "malloc" (InArg 1, InResult); - H.add allocators "calloc" (InArgTimesArg (1, 2), InResult); - H.add allocators "realloc" (InArg 2, InResult) - -(* for each deallocator, where is the data being deallocated *) -let deallocators: (string, dataLocation) H.t = H.create 13 -let _= - H.add deallocators "free" (InArg 1); - H.add deallocators "realloc" (InArg 1) - -(* Returns true if the given lvalue offset ends in a bitfield access. *) -let rec is_bitfield lo = match lo with - | NoOffset -> false - | Field(fi,NoOffset) -> not (fi.fbitfield = None) - | Field(_,lo) -> is_bitfield lo - | Index(_,lo) -> is_bitfield lo - -(* Return an expression that evaluates to the address of the given lvalue. - * For most lvalues, this is merely AddrOf(lv). However, for bitfields - * we do some offset gymnastics. - *) -let addr_of_lv (lv: lval) = - let lh, lo = lv in - if is_bitfield lo then begin - (* we figure out what the address would be without the final bitfield - * access, and then we add in the offset of the bitfield from the - * beginning of its enclosing comp *) - let rec split_offset_and_bitfield lo = match lo with - | NoOffset -> failwith "logwrites: impossible" - | Field(fi,NoOffset) -> (NoOffset,fi) - | Field(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Field(e,a)),b) - | Index(e,lo) -> let a,b = split_offset_and_bitfield lo in - ((Index(e,a)),b) - in - let new_lv_offset, bf = split_offset_and_bitfield lo in - let new_lv = (lh, new_lv_offset) in - let enclosing_type = TComp(bf.fcomp, []) in - let bits_offset, bits_width = - bitsOffset enclosing_type (Field(bf,NoOffset)) in - let bytes_offset = bits_offset / 8 in - let lvPtr = mkCast ~e:(mkAddrOf (new_lv)) ~newt:(charPtrType) in - (BinOp(PlusPI, lvPtr, (integer bytes_offset), ulongType)) - end else - (mkAddrOf (lh,lo)) - - -let mustLogLval (forwrite: bool) (lv: lval) : bool = - match lv with - Var v, off -> (* Inside a variable. We assume the array offsets are fine *) - false - | Mem e, off -> - if forwrite && not !doSfiWrites then - false - else if not forwrite && not !doSfiReads then - false - - (* If this is an lval of function type, we do not log it *) - else if isFunctionType (typeOfLval lv) then - false - else - true - -(* Create prototypes for the logging functions *) -let mkProto (name: string) (args: (string * typ * attributes) list) = - let fdec = emptyFunction name in - fdec.svar.vtype <- TFun(voidType, - Some args, false, []); - fdec - - -let logReads = mkProto "logRead" [ ("addr", voidPtrType, []); - ("what", charPtrType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogRead (lv: lval) = - let what = Pretty.sprint 80 (d_lval () lv) in - Call(None, - Lval(Var(logReads.svar),NoOffset), - [ addr_of_lv lv; mkString what; mkString !currentLoc.file; - integer !currentLoc.line], !currentLoc ) - -let logWrites = mkProto "logWrite" [ ("addr", voidPtrType, []); - ("what", charPtrType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogWrite (lv: lval) = - let what = Pretty.sprint 80 (d_lval () lv) in - Call(None, - Lval(Var(logWrites.svar), NoOffset), - [ addr_of_lv lv; mkString what; mkString !currentLoc.file; - integer !currentLoc.line], !currentLoc ) - -let logStackFrame = mkProto "logStackFrame" [ ("func", charPtrType, []) ] -let callLogStack (fname: string) = - Call(None, - Lval(Var(logStackFrame.svar), NoOffset), - [ mkString fname; ], !currentLoc ) - -let logAlloc = mkProto "logAlloc" [ ("addr", voidPtrType, []); - ("size", intType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogAlloc (szloc: dataLocation) - (resLoc: dataLocation) - (args: exp list) - (res: lval option) = - let sz = extractData szloc args res in - let res = extractData resLoc args res in - Call(None, - Lval(Var(logAlloc.svar), NoOffset), - [ res; sz; mkString !currentLoc.file; - integer !currentLoc.line ], !currentLoc ) - - -let logFree = mkProto "logFree" [ ("addr", voidPtrType, []); - ("file", charPtrType, []); - ("line", intType, []) ] -let callLogFree (dataloc: dataLocation) - (args: exp list) - (res: lval option) = - let data = extractData dataloc args res in - Call(None, - Lval(Var(logFree.svar), NoOffset), - [ data; mkString !currentLoc.file; - integer !currentLoc.line ], !currentLoc ) - -class sfiVisitorClass : Cil.cilVisitor = object (self) - inherit nopCilVisitor - - method vexpr (e: exp) : exp visitAction = - match e with - Lval lv when mustLogLval false lv -> (* A read *) - self#queueInstr [ callLogRead lv ]; - DoChildren - - | _ -> DoChildren - - - method vinst (i: instr) : instr list visitAction = - match i with - Set(lv, e, l) when mustLogLval true lv -> - self#queueInstr [ callLogWrite lv ]; - DoChildren - - | Call(lvo, f, args, l) -> - (* Instrument the write *) - (match lvo with - Some lv when mustLogLval true lv -> - self#queueInstr [ callLogWrite lv ] - | _ -> ()); - (* Do the expressions in the call, and then see if we need to - * instrument the function call *) - ChangeDoChildrenPost - ([i], - (fun il -> - currentLoc := l; - match f with - Lval (Var fv, NoOffset) -> begin - (* Is it an allocator? *) - try - let szloc, resloc = H.find allocators fv.vname in - il @ [callLogAlloc szloc resloc args lvo] - with Not_found -> begin - (* Is it a deallocator? *) - try - let resloc = H.find deallocators fv.vname in - il @ [ callLogFree resloc args lvo ] - with Not_found -> - il - end - end - | _ -> il)) - - | _ -> DoChildren - - method vfunc (fdec: fundec) = - (* Instead a stack log at the start of a function *) - ChangeDoChildrenPost - (fdec, - fun fdec -> - fdec.sbody <- - mkBlock - [ mkStmtOneInstr (callLogStack fdec.svar.vname); - mkStmt (Block fdec.sbody) ]; - fdec) - -end - -let doit (f: file) = - let sfiVisitor = new sfiVisitorClass in - let compileLoc (l: location) = function - ACons("inres", []) -> InResult - | ACons("inarg", [AInt n]) -> InArg n - | ACons("inargxarg", [AInt n1; AInt n2]) -> InArgTimesArg (n1, n2) - | ACons("pointedby", [AInt n]) -> PointedToByArg n - | _ -> E.warn "Invalid location at %a" d_loc l; - InResult - in - iterGlobals f - (fun glob -> - match glob with - GFun(fdec, _) when mustSfiFunction fdec -> - ignore (visitCilFunction sfiVisitor fdec) - | GPragma(Attr("sfiignore", al), l) -> - List.iter - (function AStr fn -> H.add skipFunctions fn () - | _ -> E.warn "Invalid argument in \"sfiignore\" pragma at %a" - d_loc l) - al - - | GPragma(Attr("sfialloc", al), l) -> begin - match al with - AStr fname :: locsz :: locres :: [] -> - H.add allocators fname (compileLoc l locsz, compileLoc l locres) - | _ -> E.warn "Invalid sfialloc pragma at %a" d_loc l - end - - | GPragma(Attr("sfifree", al), l) -> begin - match al with - AStr fname :: locwhat :: [] -> - H.add deallocators fname (compileLoc l locwhat) - | _ -> E.warn "Invalid sfifree pragma at %a" d_loc l - end - - - | _ -> ()); - (* Now add the prototypes for the instrumentation functions *) - f.globals <- - GVarDecl (logReads.svar, locUnknown) :: - GVarDecl (logWrites.svar, locUnknown) :: - GVarDecl (logStackFrame.svar, locUnknown) :: - GVarDecl (logAlloc.svar, locUnknown) :: - GVarDecl (logFree.svar, locUnknown) :: f.globals - - -let feature : featureDescr = - { fd_name = "sfi"; - fd_enabled = doSfi; - fd_description = "instrument memory operations"; - fd_extraopt = [ - "--sfireads", Arg.Set doSfiReads, "SFI for reads"; - "--sfiwrites", Arg.Set doSfiWrites, "SFI for writes"; - ]; - fd_doit = doit; - fd_post_check = true; - } - diff --git a/cil/src/ext/simplemem.ml b/cil/src/ext/simplemem.ml deleted file mode 100644 index 1b27815..0000000 --- a/cil/src/ext/simplemem.ml +++ /dev/null @@ -1,132 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* - * Simplemem: Transform a program so that all memory expressions are - * "simple". Introduce well-typed temporaries to hold intermediate values - * for expressions that would normally involve more than one memory - * reference. - * - * If simplemem succeeds, each lvalue should contain only one Mem() - * constructor. - *) -open Cil - -(* current context: where should we put our temporaries? *) -let thefunc = ref None - -(* build up a list of assignments to temporary variables *) -let assignment_list = ref [] - -(* turn "int a[5][5]" into "int ** temp" *) -let rec array_to_pointer tau = - match unrollType tau with - TArray(dest,_,al) -> TPtr(array_to_pointer dest,al) - | _ -> tau - -(* create a temporary variable in the current function *) -let make_temp tau = - let tau = array_to_pointer tau in - match !thefunc with - Some(fundec) -> makeTempVar fundec ~name:("mem_") tau - | None -> failwith "simplemem: temporary needed outside a function" - -(* separate loffsets into "scalar addition parts" and "memory parts" *) -let rec separate_loffsets lo = - match lo with - NoOffset -> NoOffset, NoOffset - | Field(fi,rest) -> - let s,m = separate_loffsets rest in - Field(fi,s) , m - | Index(_) -> NoOffset, lo - -(* Recursively decompose the lvalue so that what is under a "Mem()" - * constructor is put into a temporary variable. *) -let rec handle_lvalue (lb,lo) = - let s,m = separate_loffsets lo in - match lb with - Var(vi) -> - handle_loffset (lb,s) m - | Mem(Lval(Var(_),NoOffset)) -> - (* special case to avoid generating "tmp = ptr;" *) - handle_loffset (lb,s) m - | Mem(e) -> - begin - let new_vi = make_temp (typeOf e) in - assignment_list := (Set((Var(new_vi),NoOffset),e,!currentLoc)) - :: !assignment_list ; - handle_loffset (Mem(Lval(Var(new_vi),NoOffset)),NoOffset) lo - end -and handle_loffset lv lo = - match lo with - NoOffset -> lv - | Field(f,o) -> handle_loffset (addOffsetLval (Field(f,NoOffset)) lv) o - | Index(exp,o) -> handle_loffset (addOffsetLval (Index(exp,NoOffset)) lv) o - -(* the transformation is implemented as a Visitor *) -class simpleVisitor = object - inherit nopCilVisitor - - method vfunc fundec = (* we must record the current context *) - thefunc := Some(fundec) ; - DoChildren - - method vlval lv = ChangeDoChildrenPost(lv, - (fun lv -> handle_lvalue lv)) - - method unqueueInstr () = - let result = List.rev !assignment_list in - assignment_list := [] ; - result -end - -(* Main entry point: apply the transformation to a file *) -let simplemem (f : file) = - try - visitCilFileSameGlobals (new simpleVisitor) f; - f - with e -> Printf.printf "Exception in Simplemem.simplemem: %s\n" - (Printexc.to_string e) ; raise e - -let feature : featureDescr = - { fd_name = "simpleMem"; - fd_enabled = Cilutil.doSimpleMem; - fd_description = "simplify all memory expressions" ; - fd_extraopt = []; - fd_doit = (function (f: file) -> ignore (simplemem f)) ; - fd_post_check = true; - } diff --git a/cil/src/ext/simplify.ml b/cil/src/ext/simplify.ml deleted file mode 100755 index 776d491..0000000 --- a/cil/src/ext/simplify.ml +++ /dev/null @@ -1,845 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Sumit Gulwani - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* This module simplifies the expressions in a program in the following ways: - -1. All expressions are either - - basic::= - Const _ - Addrof(Var v, NoOffset) - StartOf(Var v, NoOffset) - Lval(Var v, off), where v is a variable whose address is not taken - and off contains only "basic" - - exp::= - basic - Lval(Mem basic, NoOffset) - BinOp(bop, basic, basic) - UnOp(uop, basic) - CastE(t, basic) - - lval ::= - Mem basic, NoOffset - Var v, off, where v is a variable whose address is not taken and off - contains only "basic" - - - all sizeof and alignof are turned into constants - - accesses to variables whose address is taken is turned into "Mem" accesses - - same for accesses to arrays - - all field and index computations are turned into address arithmetic, - including bitfields. - -*) - - -open Pretty -open Cil -module E = Errormsg -module H = Hashtbl - -type taExp = exp (* Three address expression *) -type bExp = exp (* Basic expression *) - -let debug = true - -(* Whether to split structs *) -let splitStructs = ref true - -let onlyVariableBasics = ref false -let noStringConstantsBasics = ref false - -exception BitfieldAccess - -(* Turn an expression into a three address expression (and queue some - * instructions in the process) *) -let rec makeThreeAddress - (setTemp: taExp -> bExp) (* Given an expression save it into a temp and - * return that temp *) - (e: exp) : taExp = - match e with - SizeOf _ | SizeOfE _ | AlignOf _ | AlignOfE _ | SizeOfStr _ -> - constFold true e - | Const _ -> e - | AddrOf (Var _, NoOffset) -> e - | Lval lv -> Lval (simplifyLval setTemp lv) - | BinOp(bo, e1, e2, tres) -> - BinOp(bo, makeBasic setTemp e1, makeBasic setTemp e2, tres) - | UnOp(uo, e1, tres) -> - UnOp(uo, makeBasic setTemp e1, tres) - | CastE(t, e) -> - CastE(t, makeBasic setTemp e) - | AddrOf lv -> begin - match simplifyLval setTemp lv with - Mem a, NoOffset -> a - | _ -> (* This is impossible, because we are taking the address - * of v and simplifyLval should turn it into a Mem, except if the - * sizeof has failed. *) - E.s (bug "Simplify: makeThreeAddress for AddrOf(LV=%a, LVT=%a)" - d_lval lv d_type (typeOfLval lv)) - end - | StartOf lv -> - makeThreeAddress setTemp (AddrOf (addOffsetLval (Index(zero, NoOffset)) - lv)) - -(* Make a basic expression *) -and makeBasic (setTemp: taExp -> bExp) (e: exp) : bExp = - let dump = false (* !currentLoc.line = 395 *) in - if dump then - ignore (E.log "makeBasic %a\n" d_plainexp e); - (* Make it a three address expression first *) - let e' = makeThreeAddress setTemp e in - if dump then - ignore (E.log " e'= %a\n" d_plainexp e); - (* See if it is a basic one *) - match e' with - | Lval (Var _, _) -> e' - | Const _ | AddrOf (Var _, NoOffset) | StartOf (Var _, NoOffset) -> - if !onlyVariableBasics then setTemp e' else e' - | SizeOf _ | SizeOfE _ | AlignOf _ | AlignOfE _ | SizeOfStr _ -> - E.s (bug "Simplify: makeBasic found SizeOf: %a" d_exp e') - - (* We cannot make a function to be Basic, unless it actually is a variable - * already. If this is a function pointer the best we can do is to make - * the address of the function basic *) - | Lval (Mem a, NoOffset) when isFunctionType (typeOf e') -> - if dump then - ignore (E.log " a function type\n"); - let a' = makeBasic setTemp a in - Lval (Mem a', NoOffset) - - | _ -> setTemp e' (* Put it into a temporary otherwise *) - - -and simplifyLval - (setTemp: taExp -> bExp) - (lv: lval) : lval = - (* Add, watching for a zero *) - let add (e1: exp) (e2: exp) = - if isZero e2 then e1 else BinOp(PlusA, e1, e2, !upointType) - in - (* Convert an offset to an integer, and possibly a residual bitfield offset*) - let rec offsetToInt - (t: typ) (* The type of the host *) - (off: offset) : exp * offset = - match off with - NoOffset -> zero, NoOffset - | Field(fi, off') -> begin - let start = - try - let start, _ = bitsOffset t (Field(fi, NoOffset)) in - start - with SizeOfError (whystr, t') -> - E.s (E.bug "%a: Cannot compute sizeof: %s: %a" - d_loc !currentLoc whystr d_type t') - in - if start land 7 <> 0 then begin - (* We have a bitfield *) - assert (off' = NoOffset); - zero, Field(fi, off') - end else begin - let next, restoff = offsetToInt fi.ftype off' in - add (integer (start / 8)) next, restoff - end - end - | Index(ei, off') -> begin - let telem = match unrollType t with - TArray(telem, _, _) -> telem - | _ -> E.s (bug "Simplify: simplifyLval: index on a non-array") - in - let next, restoff = offsetToInt telem off' in - add - (BinOp(Mult, ei, SizeOf telem, !upointType)) - next, - restoff - end - in - let tres = TPtr(typeOfLval lv, []) in - match lv with - Mem a, off -> - let offidx, restoff = offsetToInt (typeOfLval (Mem a, NoOffset)) off in - let a' = - if offidx <> zero then - add (mkCast a !upointType) offidx - else - a - in - let a' = makeBasic setTemp a' in - Mem (mkCast a' tres), restoff - - | Var v, off when v.vaddrof -> (* We are taking this variable's address *) - let offidx, restoff = offsetToInt v.vtype off in - (* We cannot call makeBasic recursively here, so we must do it - * ourselves *) - let a = mkAddrOrStartOf (Var v, NoOffset) in - let a' = - if offidx = zero then a else - add (mkCast a !upointType) (makeBasic setTemp offidx) - in - let a' = setTemp a' in - Mem (mkCast a' tres), restoff - - | Var v, off -> - (Var v, simplifyOffset setTemp off) - - -(* Simplify an offset and make sure it has only three address expressions in - * indices *) -and simplifyOffset (setTemp: taExp -> bExp) = function - NoOffset -> NoOffset - | Field(fi, off) -> Field(fi, simplifyOffset setTemp off) - | Index(ei, off) -> - let ei' = makeBasic setTemp ei in - Index(ei', simplifyOffset setTemp off) - - - - -(** This is a visitor that will turn all expressions into three address code *) -class threeAddressVisitor (fi: fundec) = object (self) - inherit nopCilVisitor - - method private makeTemp (e1: exp) : exp = - let t = makeTempVar fi (typeOf e1) in - (* Add this instruction before the current statement *) - self#queueInstr [Set(var t, e1, !currentLoc)]; - Lval(var t) - - (* We'll ensure that this gets called only for top-level expressions - * inside functions. We must turn them into three address code. *) - method vexpr (e: exp) = - let e' = makeThreeAddress self#makeTemp e in - ChangeTo e' - - - (** We want the argument in calls to be simple variables *) - method vinst (i: instr) = - match i with - Call (someo, f, args, loc) -> - let someo' = - match someo with - Some lv -> Some (simplifyLval self#makeTemp lv) - | _ -> None - in - let f' = makeBasic self#makeTemp f in - let args' = List.map (makeBasic self#makeTemp) args in - ChangeTo [ Call (someo', f', args', loc) ] - | _ -> DoChildren - - (* This method will be called only on top-level "lvals" (those on the - * left of assignments and function calls) *) - method vlval (lv: lval) = - ChangeTo (simplifyLval self#makeTemp lv) -end - -(******************** - Next is an old version of the code that was splitting structs into - * variables. It was not working on variables that are arguments or returns - * of function calls. -(** This is a visitor that splits structured variables into separate - * variables. *) -let isStructType (t: typ): bool = - match unrollType t with - TComp (ci, _) -> ci.cstruct - | _ -> false - -(* Keep track of how we change the variables. For each variable id we keep a - * hash table that maps an offset (a sequence of fieldinfo) into a - * replacement variable. We also keep track of the splittable vars: those - * with structure type but whose address is not take and which do not appear - * as the argument to a Return *) -let splittableVars: (int, unit) H.t = H.create 13 -let replacementVars: (int * offset, varinfo) H.t = H.create 13 - -let findReplacement (fi: fundec) (v: varinfo) (off: offset) : varinfo = - try - H.find replacementVars (v.vid, off) - with Not_found -> begin - let t = typeOfLval (Var v, off) in - (* make a name for this variable *) - let rec mkName = function - | Field(fi, off) -> "_" ^ fi.fname ^ mkName off - | _ -> "" - in - let v' = makeTempVar fi ~name:(v.vname ^ mkName off ^ "_") t in - H.add replacementVars (v.vid, off) v'; - if debug then - ignore (E.log "Simplify: %s (%a) replace %a with %s\n" - fi.svar.vname - d_loc !currentLoc - d_lval (Var v, off) - v'.vname); - v' - end - - (* Now separate the offset into a sequence of field accesses and the - * rest of the offset *) -let rec separateOffset (off: offset): offset * offset = - match off with - NoOffset -> NoOffset, NoOffset - | Field(fi, off') when fi.fcomp.cstruct -> - let off1, off2 = separateOffset off' in - Field(fi, off1), off2 - | _ -> NoOffset, off - - -class splitStructVisitor (fi: fundec) = object (self) - inherit nopCilVisitor - - method vlval (lv: lval) = - match lv with - Var v, off when H.mem splittableVars v.vid -> - (* The type of this lval better not be a struct *) - if isStructType (typeOfLval lv) then - E.s (unimp "Simplify: found lval of struct type %a : %a\n" - d_lval lv d_type (typeOfLval lv)); - let off1, restoff = separateOffset off in - let lv' = - if off1 <> NoOffset then begin - (* This is a splittable variable and we have an offset that makes - * it a scalar. Find the replacement variable for this *) - let v' = findReplacement fi v off1 in - if restoff = NoOffset then - Var v', NoOffset - else (* We have some more stuff. Use Mem *) - Mem (mkAddrOrStartOf (Var v', NoOffset)), restoff - end else begin (* off1 = NoOffset *) - if restoff = NoOffset then - E.s (bug "Simplify: splitStructVisitor:lval") - else - simplifyLval - (fun e1 -> - let t = makeTempVar fi (typeOf e1) in - (* Add this instruction before the current statement *) - self#queueInstr [Set(var t, e1, !currentLoc)]; - Lval(var t)) - (Mem (mkAddrOrStartOf (Var v, NoOffset)), restoff) - end - in - ChangeTo lv' - - | _ -> DoChildren - - method vinst (i: instr) = - (* Accumulate to the list of instructions a number of assignments of - * non-splittable lvalues *) - let rec accAssignment (ci: compinfo) (dest: lval) (what: lval) - (acc: instr list) : instr list = - List.fold_left - (fun acc f -> - let dest' = addOffsetLval (Field(f, NoOffset)) dest in - let what' = addOffsetLval (Field(f, NoOffset)) what in - match unrollType f.ftype with - TComp(ci, _) when ci.cstruct -> - accAssignment ci dest' what' acc - | TArray _ -> (* We must copy the array *) - (Set((Mem (AddrOf dest'), NoOffset), - Lval (Mem (AddrOf what'), NoOffset), !currentLoc)) :: acc - | _ -> (* If the type of f is not a struct then leave this alone *) - (Set(dest', Lval what', !currentLoc)) :: acc) - acc - ci.cfields - in - let doAssignment (ci: compinfo) (dest: lval) (what: lval) : instr list = - let il' = accAssignment ci dest what [] in - List.concat (List.map (visitCilInstr (self :> cilVisitor)) il') - in - match i with - Set(((Var v, off) as lv), what, _) when H.mem splittableVars v.vid -> - let off1, restoff = separateOffset off in - if restoff <> NoOffset then (* This means that we are only assigning - * part of a replacement variable. Leave - * this alone because the vlval will take - * care of it *) - DoChildren - else begin - (* The type of the replacement has to be a structure *) - match unrollType (typeOfLval lv) with - TComp (ci, _) when ci.cstruct -> - (* The assigned thing better be an lvalue *) - let whatlv = - match what with - Lval lv -> lv - | _ -> E.s (unimp "Simplify: assigned struct is not lval") - in - ChangeTo (doAssignment ci (Var v, off) whatlv) - - | _ -> (* vlval will take care of it *) - DoChildren - end - - | Set(dest, Lval (Var v, off), _) when H.mem splittableVars v.vid -> - let off1, restoff = separateOffset off in - if restoff <> NoOffset then (* vlval will do this *) - DoChildren - else begin - (* The type of the replacement has to be a structure *) - match unrollType (typeOfLval dest) with - TComp (ci, _) when ci.cstruct -> - ChangeTo (doAssignment ci dest (Var v, off)) - - | _ -> (* vlval will take care of it *) - DoChildren - end - - | _ -> DoChildren - -end -*) - -(* Whether to split the arguments of functions *) -let splitArguments = true - -(* Whether we try to do the splitting all in one pass. The advantage is that - * it is faster and it generates nicer names *) -let lu = locUnknown - -(* Go over the code and split some temporary variables of stucture type into - * several separate variables. The hope is that the compiler will have an - * easier time to do standard optimizations with the resulting scalars *) -(* Unfortunately, implementing this turns out to be more complicated than I - * thought *) - -(** Iterate over the fields of a structured type. Returns the empty list if - * no splits. The offsets are in order in which they appear in the structure - * type. Along with the offset we pass a string that identifies the - * meta-component, and the type of that component. *) -let rec foldRightStructFields - (doit: offset -> string -> typ -> 'a) (* Invoked on non-struct fields *) - (off: offset) - (post: 'a list) (** A suffix to what you compute *) - (fields: fieldinfo list) : 'a list = - List.fold_right - (fun f post -> - let off' = addOffset (Field(f, NoOffset)) off in - match unrollType f.ftype with - TComp (comp, _) when comp.cstruct -> (* struct type: recurse *) - foldRightStructFields doit off' post comp.cfields - | _ -> - (doit off' f.fname f.ftype) :: post) - fields - post - - -let rec foldStructFields - (t: typ) - (doit: offset -> string -> typ -> 'a) - : 'a list = - match unrollType t with - TComp (comp, _) when comp.cstruct -> - foldRightStructFields doit NoOffset [] comp.cfields - | _ -> [] - - -(* Map a variable name to a list of component variables, along with the - * accessor offset. The fields are in the order in which they appear in the - * structure. *) -let newvars : (string, (offset * varinfo) list) H.t = H.create 13 - -(* Split a variable and return the replacements, in the proper order. If this - * variable is not split, then return just the variable. *) -let splitOneVar (v: varinfo) - (mknewvar: string -> typ -> varinfo) : varinfo list = - try - (* See if we have already split it *) - List.map snd (H.find newvars v.vname) - with Not_found -> begin - let vars: (offset * varinfo) list = - foldStructFields v.vtype - (fun off n t -> (* make a new one *) - let newname = v.vname ^ "_" ^ n in - let v'= mknewvar newname t in - (off, v')) - in - if vars = [] then - [ v ] - else begin - (* Now remember the newly created vars *) - H.add newvars v.vname vars; - List.map snd vars (* Return just the vars *) - end - end - - -(* A visitor that finds all locals that appear in a call or have their - * address taken *) -let dontSplitLocals : (string, bool) H.t = H.create 111 -class findVarsCantSplitClass : cilVisitor = object (self) - inherit nopCilVisitor - - (* expressions, to see the address being taken *) - method vexpr (e: exp) : exp visitAction = - match e with - AddrOf (Var v, NoOffset) -> - H.add dontSplitLocals v.vname true; SkipChildren - (* See if we take the address of the "_ms" field in a variable *) - | _ -> DoChildren - - - (* variables involved in call instructions *) - method vinst (i: instr) : instr list visitAction = - match i with - Call (res, f, args, _) -> - (match res with - Some (Var v, NoOffset) -> H.add dontSplitLocals v.vname true - | _ -> ()); - if not splitArguments then - List.iter (fun a -> - match a with - Lval (Var v, NoOffset) -> H.add dontSplitLocals v.vname true - | _ -> ()) args; - (* Now continue the visit *) - DoChildren - - | _ -> DoChildren - - (* Variables used in return should not be split *) - method vstmt (s: stmt) : stmt visitAction = - match s.skind with - Return (Some (Lval (Var v, NoOffset)), _) -> - H.add dontSplitLocals v.vname true; DoChildren - | Return (Some e, _) -> - DoChildren - | _ -> DoChildren - - method vtype t = SkipChildren - -end -let findVarsCantSplit = new findVarsCantSplitClass - -let isVar lv = - match lv with - (Var v, NoOffset) -> true - | _ -> false - - -class splitVarVisitorClass(func:fundec option) : cilVisitor = object (self) - inherit nopCilVisitor - - method private makeTemp (e1: exp) : exp = - let fi:fundec = match func with - Some f -> f - | None -> - E.s (bug "You can't create a temporary if you're not in a function.") - in - let t = makeTempVar fi (typeOf e1) in - (* Add this instruction before the current statement *) - self#queueInstr [Set(var t, e1, !currentLoc)]; - Lval(var t) - - - (* We must process the function types *) - method vtype t = - (* We invoke the visitor first and then we fix it *) - let postProcessFunType (t: typ) : typ = - match t with - TFun(rt, Some params, isva, a) -> - let rec loopParams = function - [] -> [] - | ((pn, pt, pa) :: rest) as params -> - let rest' = loopParams rest in - let res: (string * typ * attributes) list = - foldStructFields pt - (fun off n t -> - (* Careful with no-name parameters, or we end up with - * many parameters named _p ! *) - ((if pn <> "" then pn ^ n else ""), t, pa)) - in - if res = [] then (* Not a fat *) - if rest' == rest then - params (* No change at all. Try not to reallocate so that - * the visitor does not allocate. *) - else - (pn, pt, pa) :: rest' - else (* Some change *) - res @ rest' - in - let params' = loopParams params in - if params == params' then - t - else - TFun(rt, Some params', isva, a) - - | t -> t - in - if splitArguments then - ChangeDoChildrenPost(t, postProcessFunType) - else - SkipChildren - - (* Whenever we see a variable with a field access we try to replace it - * by its components *) - method vlval ((b, off) : lval) : lval visitAction = - try - match b, off with - Var v, (Field _ as off) -> - (* See if this variable has some splits.Might throw Not_found *) - let splits = H.find newvars v.vname in - (* Now find among the splits one that matches this offset. And - * return the remaining offset *) - let rec find = function - [] -> - E.s (E.bug "Cannot find component %a of %s\n" - (d_offset nil) off v.vname) - | (splitoff, splitvar) :: restsplits -> - let rec matches = function - Field(f1, rest1), Field(f2, rest2) - when f1.fname = f2.fname -> - matches (rest1, rest2) - | off, NoOffset -> - (* We found a match *) - (Var splitvar, off) - | NoOffset, restoff -> - ignore (warn "Found aggregate lval %a\n" - d_lval (b, off)); - find restsplits - - | _, _ -> (* We did not match this one; go on *) - find restsplits - in - matches (off, splitoff) - in - ChangeTo (find splits) - | _ -> DoChildren - with Not_found -> DoChildren - - (* Sometimes we pass the variable as a whole to a function or we - * assign it to something *) - method vinst (i: instr) : instr list visitAction = - match i with - (* Split into several instructions and then do children inside - * the rhs. Howver, v might appear in the rhs and if we - * duplicate the instruction we might get bad - * results. (e.g. test/small1/simplify_Structs2.c). So first copy - * the rhs to temp variables, then to v. - * - * Optimization: if the rhs is a variable, skip the temporary vars. - * Either the rhs = lhs, in which case this is all a nop, or it's not, - * in which case the rhs and lhs don't overlap.*) - - Set ((Var v, NoOffset), Lval lv, l) when H.mem newvars v.vname -> begin - let needTemps = not (isVar lv) in - let vars4v = H.find newvars v.vname in - if vars4v = [] then E.s (errorLoc l "No fields in split struct"); - ChangeTo - (List.map - (fun (off, newv) -> - let lv' = - visitCilLval (self :> cilVisitor) - (addOffsetLval off lv) in - (* makeTemp creates a temp var and puts (Lval lv') in it, - before any instructions in this ChangeTo list are handled.*) - let lv_tmp = if needTemps then - self#makeTemp (Lval lv') - else - (Lval lv') - in - Set((Var newv, NoOffset), lv_tmp, l)) - vars4v) - end - - | Set (lv, Lval (Var v, NoOffset), l) when H.mem newvars v.vname -> begin - (* Split->NonSplit assignment. no overlap between lhs and rhs - is possible*) - let vars4v = H.find newvars v.vname in - if vars4v = [] then E.s (errorLoc l "No fields in split struct"); - ChangeTo - (List.map - (fun (off, newv) -> - let lv' = - visitCilLval (self :> cilVisitor) - (addOffsetLval off lv) in - Set(lv', Lval (Var newv, NoOffset), l)) - vars4v) - end - - (* Split all function arguments in calls *) - | Call (ret, f, args, l) when splitArguments -> - (* Visit the children first and then see if we must change the - * arguments *) - let finishArgs = function - [Call (ret', f', args', l')] as i' -> - let mustChange = ref false in - let newargs = - (* Look for opportunities to split arguments. If we can - * split, we must split the original argument (in args). - * Otherwise, we use the result of processing children - * (in args'). *) - List.fold_right2 - (fun a a' acc -> - match a with - Lval (Var v, NoOffset) when H.mem newvars v.vname -> - begin - mustChange := true; - (List.map - (fun (_, newv) -> - Lval (Var newv, NoOffset)) - (H.find newvars v.vname)) - @ acc - end - | Lval lv -> begin - let newargs = - foldStructFields (typeOfLval lv) - (fun off n t -> - let lv' = addOffsetLval off lv in - Lval lv') in - if newargs = [] then - a' :: acc (* not a split var *) - else begin - mustChange := true; - newargs @ acc - end - end - | _ -> (* only lvals are split, right? *) - a' :: acc) - args args' - [] - in - if !mustChange then - [Call (ret', f', newargs, l')] - else - i' - | _ -> E.s (E.bug "splitVarVisitorClass: expecting call") - in - ChangeDoChildrenPost ([i], finishArgs) - - | _ -> DoChildren - - - method vfunc (func: fundec) : fundec visitAction = - H.clear newvars; - H.clear dontSplitLocals; - (* Visit the type of the function itself *) - if splitArguments then - func.svar.vtype <- visitCilType (self :> cilVisitor) func.svar.vtype; - - (* Go over the block and find the candidates *) - ignore (visitCilBlock findVarsCantSplit func.sbody); - - (* Now go over the formals and create the splits *) - if splitArguments then begin - (* Split all formals because we will split all arguments in function - * types *) - let newformals = - List.fold_right - (fun form acc -> - (* Process the type first *) - form.vtype <- - visitCilType (self : #cilVisitor :> cilVisitor) form.vtype; - let form' = - splitOneVar form - (fun s t -> makeLocalVar func ~insert:false s t) - in - (* Now it is a good time to check if we actually can split this - * one *) - if List.length form' > 1 && - H.mem dontSplitLocals form.vname then - ignore (warn "boxsplit: can't split formal \"%s\" in %s. Make sure you never take the address of a formal.\n" - form.vname func.svar.vname); - form' @ acc) - func.sformals [] - in - (* Now make sure we fix the type. *) - setFormals func newformals - end; - (* Now go over the locals and create the splits *) - List.iter - (fun l -> - (* Process the type of the local *) - l.vtype <- visitCilType (self :> cilVisitor) l.vtype; - (* Now see if we must split it *) - if not (H.mem dontSplitLocals l.vname) then begin - ignore (splitOneVar l (fun s t -> makeTempVar func ~name:s t)) - end) - func.slocals; - (* Now visit the body and change references to these variables *) - ignore (visitCilBlock (self :> cilVisitor) func.sbody); - H.clear newvars; - H.clear dontSplitLocals; - SkipChildren (* We are done with this function *) - - (* Try to catch the occurrences of the variable in a sizeof expression *) - method vexpr (e: exp) = - match e with - | SizeOfE (Lval(Var v, NoOffset)) -> begin - try - let splits = H.find newvars v.vname in - (* We cound here on no padding between the elements ! *) - ChangeTo - (List.fold_left - (fun acc (_, thisv) -> - BinOp(PlusA, SizeOfE(Lval(Var thisv, NoOffset)), - acc, uintType)) - zero - splits) - with Not_found -> DoChildren - end - | _ -> DoChildren -end - -let doGlobal = function - GFun(fi, _) -> - (* Visit the body and change all expressions into three address code *) - let v = new threeAddressVisitor fi in - fi.sbody <- visitCilBlock v fi.sbody; - if !splitStructs then begin - H.clear dontSplitLocals; - let splitVarVisitor = new splitVarVisitorClass (Some fi) in - ignore (visitCilFunction splitVarVisitor fi); - end - | GVarDecl(vi, _) when isFunctionType vi.vtype -> - (* we might need to split the args/return value in the function type. *) - if !splitStructs then begin - H.clear dontSplitLocals; - let splitVarVisitor = new splitVarVisitorClass None in - ignore (visitCilVarDecl splitVarVisitor vi); - end - | _ -> () - -let feature : featureDescr = - { fd_name = "simplify"; - fd_enabled = ref false; - fd_description = "compiles CIL to 3-address code"; - fd_extraopt = [ - ("--no-split-structs", Arg.Unit (fun _ -> splitStructs := false), - "do not split structured variables"); - ]; - fd_doit = (function f -> iterGlobals f doGlobal); - fd_post_check = true; -} - diff --git a/cil/src/ext/ssa.ml b/cil/src/ext/ssa.ml deleted file mode 100644 index 942c92b..0000000 --- a/cil/src/ext/ssa.ml +++ /dev/null @@ -1,696 +0,0 @@ -module B=Bitmap -module E = Errormsg - -open Cil -open Pretty - -let debug = false - -(* Globalsread, Globalswritten should be closed under call graph *) - -module StringOrder = - struct - type t = string - let compare s1 s2 = - if s1 = s2 then 0 else - if s1 < s2 then -1 else 1 - end - -module StringSet = Set.Make (StringOrder) - -module IntOrder = - struct - type t = int - let compare i1 i2 = - if i1 = i2 then 0 else - if i1 < i2 then -1 else 1 - end - -module IntSet = Set.Make (IntOrder) - - -type cfgInfo = { - name: string; (* The function name *) - start : int; - size : int; - blocks: cfgBlock array; (** Dominating blocks must come first *) - successors: int list array; (* block indices *) - predecessors: int list array; - mutable nrRegs: int; - mutable regToVarinfo: varinfo array; (** Map register IDs to varinfo *) - } - -(** A block corresponds to a statement *) -and cfgBlock = { - bstmt: Cil.stmt; - - (* We abstract the statement as a list of def/use instructions *) - instrlist: instruction list; - mutable livevars: (reg * int) list; - (** For each variable ID that is live at the start of the block, the - * block whose definition reaches this point. If that block is the same - * as the current one, then the variable is a phi variable *) - mutable reachable: bool; - } - -and instruction = (reg list * reg list) - (* lhs variables, variables on rhs. *) - - -and reg = int - -type idomInfo = int array (* immediate dominator *) - -and dfInfo = (int list) array (* dominance frontier *) - -and oneSccInfo = { - nodes: int list; - headers: int list; - backEdges: (int*int) list; - } - -and sccInfo = oneSccInfo list - -(* Muchnick's Domin_Fast, 7.16 *) - -let compute_idom (flowgraph: cfgInfo): idomInfo = - let start = flowgraph.start in - let size = flowgraph.size in - let successors = flowgraph.successors in - let predecessors = flowgraph.predecessors in - let n0 = size in (* a new node (not in the flowgraph) *) - let idom = Array.make size (-1) in (* Make an array of immediate dominators *) - let nnodes = size + 1 in - let nodeSet = B.init nnodes (fun i -> true) in - - let ndfs = Array.create nnodes 0 in (* mapping from depth-first - * number to nodes. DForder - * starts at 1, with 0 used as - * an invalid entry *) - let parent = Array.create nnodes 0 in (* the parent in depth-first - * spanning tree *) - - (* A semidominator of w is the node v with the minimal DForder such - * that there is a path from v to w containing only nodes with the - * DForder larger than w. *) - let sdno = Array.create nnodes 0 in (* depth-first number of - * semidominator *) - - (* The set of nodes whose - * semidominator is ndfs(i) *) - let bucket = Array.init nnodes (fun _ -> B.cloneEmpty nodeSet) in - - (* The functions link and eval maintain a forest within the - * depth-first spanning tree. Ancestor is n0 is the node is a root in - * the forest. Label(v) is the node in the ancestor chain with the - * smallest depth-first number of its semidominator. Child and Size - * are used to keep the trees in the forest balanced *) - let ancestor = Array.create nnodes 0 in - let label = Array.create nnodes 0 in - let child = Array.create nnodes 0 in - let size = Array.create nnodes 0 in - - - let n = ref 0 in (* depth-first scan and numbering. - * Initialize data structures. *) - ancestor.(n0) <- n0; - label.(n0) <- n0; - let rec depthFirstSearchDom v = - incr n; - sdno.(v) <- !n; - ndfs.(!n) <- v; label.(v) <- v; - ancestor.(v) <- n0; (* All nodes are roots initially *) - child.(v) <- n0; size.(v) <- 1; - List.iter - (fun w -> - if sdno.(w) = 0 then begin - parent.(w) <- v; depthFirstSearchDom w - end) - successors.(v); - in - (* Determine the ancestor of v whose semidominator has the the minimal - * DFnumber. In the process, compress the paths in the forest. *) - let eval v = - let rec compress v = - if ancestor.(ancestor.(v)) <> n0 then - begin - compress ancestor.(v); - if sdno.(label.(ancestor.(v))) < sdno.(label.(v)) then - label.(v) <- label.(ancestor.(v)); - ancestor.(v) <- ancestor.(ancestor.(v)) - end - in - if ancestor.(v) = n0 then label.(v) - else begin - compress v; - if sdno.(label.(ancestor.(v))) >= sdno.(label.(v)) then - label.(v) - else label.(ancestor.(v)) - end - in - - let link v w = - let s = ref w in - while sdno.(label.(w)) < sdno.(label.(child.(!s))) do - if size.(!s) + size.(child.(child.(!s))) >= 2* size.(child.(!s)) then - (ancestor.(child.(!s)) <- !s; - child.(!s) <- child.(child.(!s))) - else - (size.(child.(!s)) <- size.(!s); - ancestor.(!s) <- child.(!s); s := child.(!s)); - done; - label.(!s) <- label.(w); - size.(v) <- size.(v) + size.(w); - if size.(v) < 2 * size.(w) then begin - let tmp = !s in - s := child.(v); - child.(v) <- tmp; - end; - while !s <> n0 do - ancestor.(!s) <- v; - s := child.(!s); - done; - in - (* Start now *) - depthFirstSearchDom start; - for i = !n downto 2 do - let w = ndfs.(i) in - List.iter (fun v -> - let u = eval v in - if sdno.(u) < sdno.(w) then sdno.(w) <- sdno.(u);) - predecessors.(w); - B.set bucket.(ndfs.(sdno.(w))) w true; - link parent.(w) w; - while not (B.empty bucket.(parent.(w))) do - let v = - match B.toList bucket.(parent.(w)) with - x :: _ -> x - | [] -> ignore(print_string "Error in dominfast");0 in - B.set bucket.(parent.(w)) v false; - let u = eval v in - idom.(v) <- if sdno.(u) < sdno.(v) then u else parent.(w); - done; - done; - - for i=2 to !n do - let w = ndfs.(i) in - if idom.(w) <> ndfs.(sdno.(w)) then begin - let newDom = idom.(idom.(w)) in - idom.(w) <- newDom; - end - done; - idom - - - - - -let dominance_frontier (flowgraph: cfgInfo) : dfInfo = - let idom = compute_idom flowgraph in - let size = flowgraph.size in - let children = Array.create size [] in - for i = 0 to size - 1 do - if (idom.(i) != -1) then children.(idom.(i)) <- i :: children.(idom.(i)); - done; - - let size = flowgraph.size in - let start = flowgraph.start in - let successors = flowgraph.successors in - - let df = Array.create size [] in - (* Compute the dominance frontier *) - - let bottom = Array.make size true in (* bottom of the dominator tree *) - for i = 0 to size - 1 do - if (i != start) && idom.(i) <> -1 then bottom.(idom.(i)) <- false; - done; - - let processed = Array.make size false in (* to record the nodes added to work_list *) - let workList = ref ([]) in (* to iterate in a bottom-up traversal of the dominator tree *) - for i = 0 to size - 1 do - if (bottom.(i)) then workList := i :: !workList; - done; - while (!workList != []) do - let x = List.hd !workList in - let update y = if idom.(y) <> x then df.(x) <- y::df.(x) in - (* compute local component *) - -(* We use whichPred instead of whichSucc because ultimately this info is - * needed by control dependence dag which is constructed from REVERSE - * dominance frontier *) - List.iter (fun succ -> update succ) successors.(x); - (* add on up component *) - List.iter (fun z -> List.iter (fun y -> update y) df.(z)) children.(x); - processed.(x) <- true; - workList := List.tl !workList; - if (x != start) then begin - let i = idom.(x) in - if i <> -1 && - (List.for_all (fun child -> processed.(child)) children.(i)) then workList := i :: !workList; - end; - done; - df - - -(* Computes for each register, the set of nodes that need a phi definition - * for the register *) - -let add_phi_functions_info (flowgraph: cfgInfo) : unit = - let df = dominance_frontier flowgraph in - let size = flowgraph.size in - let nrRegs = flowgraph.nrRegs in - - - let defs = Array.init size (fun i -> B.init nrRegs (fun j -> false)) in - for i = 0 to size-1 do - List.iter - (fun (lhs,rhs) -> - List.iter (fun (r: reg) -> B.set defs.(i) r true) lhs; - ) - flowgraph.blocks.(i).instrlist - done; - let iterCount = ref 0 in - let hasAlready = Array.create size 0 in - let work = Array.create size 0 in - let w = ref ([]) in - let dfPlus = Array.init nrRegs ( - fun i -> - let defIn = B.make size in - for j = 0 to size - 1 do - if B.get defs.(j) i then B.set defIn j true - done; - let res = ref [] in - incr iterCount; - B.iter (fun x -> work.(x) <- !iterCount; w := x :: !w;) defIn; - while (!w != []) do - let x = List.hd !w in - w := List.tl !w; - List.iter (fun y -> - if (hasAlready.(y) < !iterCount) then begin - res := y :: !res; - hasAlready.(y) <- !iterCount; - if (work.(y) < !iterCount) then begin - work.(y) <- !iterCount; - w := y :: !w; - end; - end; - ) df.(x) - done; - (* res := List.filter (fun blkId -> B.get liveIn.(blkId) i) !res; *) - !res - ) in - let result = Array.create size ([]) in - for i = 0 to nrRegs - 1 do - List.iter (fun node -> result.(node) <- i::result.(node);) dfPlus.(i) - done; -(* result contains for each node, the list of variables that need phi - * definition *) - for i = 0 to size-1 do - flowgraph.blocks.(i).livevars <- - List.map (fun r -> (r, i)) result.(i); - done - - - -(* add dominating definitions info *) - -let add_dom_def_info (f: cfgInfo): unit = - let blocks = f.blocks in - let start = f.start in - let size = f.size in - let nrRegs = f.nrRegs in - - let idom = compute_idom f in - let children = Array.create size [] in - for i = 0 to size - 1 do - if (idom.(i) != -1) then children.(idom.(i)) <- i :: children.(idom.(i)); - done; - - if debug then begin - ignore (E.log "Immediate dominators\n"); - for i = 0 to size - 1 do - ignore (E.log " block %d: idom=%d, children=%a\n" - i idom.(i) - (docList num) children.(i)); - done - end; - - (* For each variable, maintain a stack of blocks that define it. When you - * process a block, the top of the stack is the closest dominator that - * defines the variable *) - let s = Array.make nrRegs ([start]) in - - (* Search top-down in the idom tree *) - let rec search (x: int): unit = (* x is a graph node *) - (* Push the current block for the phi variables *) - List.iter - (fun ((r: reg), dr) -> - if x = dr then s.(r) <- x::s.(r)) - blocks.(x).livevars; - - (* Clear livevars *) - blocks.(x).livevars <- []; - - (* Compute livevars *) - for i = 0 to nrRegs-1 do - match s.(i) with - | [] -> assert false - | fst :: _ -> - blocks.(x).livevars <- (i, fst) :: blocks.(x).livevars - done; - - - (* Update s for the children *) - List.iter - (fun (lhs,rhs) -> - List.iter (fun (lreg: reg) -> s.(lreg) <- x::s.(lreg) ) lhs; - ) - blocks.(x).instrlist; - - - (* Go and do the children *) - List.iter search children.(x); - - (* Then we pop x, whenever it is on top of a stack *) - Array.iteri - (fun i istack -> - let rec dropX = function - [] -> [] - | x' :: rest when x = x' -> dropX rest - | l -> l - in - s.(i) <- dropX istack) - s; - in - search(start) - - - -let prune_cfg (f: cfgInfo): cfgInfo = - let size = f.size in - if size = 0 then f else - let reachable = Array.make size false in - let worklist = ref([f.start]) in - while (!worklist != []) do - let h = List.hd !worklist in - worklist := List.tl !worklist; - reachable.(h) <- true; - List.iter (fun s -> if (reachable.(s) = false) then worklist := s::!worklist; - ) f.successors.(h); - done; -(* - let dummyblock = { bstmt = mkEmptyStmt (); - instrlist = []; - livevars = [] } - in -*) - let successors = Array.init size (fun i -> List.filter (fun s -> reachable.(s)) f.successors.(i)) in - let predecessors = Array.init size (fun i -> List.filter (fun s -> reachable.(s)) f.predecessors.(i)) in - Array.iteri (fun i b -> b.reachable <- reachable.(i)) f.blocks; - let result: cfgInfo = - { name = f.name; - start = f.start; - size = f.size; - successors = successors; - predecessors = predecessors; - blocks = f.blocks; - nrRegs = f.nrRegs; - regToVarinfo = f.regToVarinfo; - } - in - result - - -let add_ssa_info (f: cfgInfo): unit = - let f = prune_cfg f in - let d_reg () (r: int) = - dprintf "%s(%d)" f.regToVarinfo.(r).vname r - in - if debug then begin - ignore (E.log "Doing SSA for %s. Initial data:\n" f.name); - Array.iteri (fun i b -> - ignore (E.log " block %d:\n succs=@[%a@]\n preds=@[%a@]\n instr=@[%a@]\n" - i - (docList num) f.successors.(i) - (docList num) f.predecessors.(i) - (docList ~sep:line (fun (lhs, rhs) -> - dprintf "%a := @[%a@]" - (docList (d_reg ())) lhs (docList (d_reg ())) rhs)) - b.instrlist)) - f.blocks; - end; - - add_phi_functions_info f; - add_dom_def_info f; - - if debug then begin - ignore (E.log "After SSA\n"); - Array.iter (fun b -> - ignore (E.log " block %d livevars: @[%a@]\n" - b.bstmt.sid - (docList (fun (i, fst) -> - dprintf "%a def at %d" d_reg i fst)) - b.livevars)) - f.blocks; - end - - -let set2list s = - let result = ref([]) in - IntSet.iter (fun element -> result := element::!result) s; - !result - - - - -let preorderDAG (nrNodes: int) (successors: (int list) array): int list = - let processed = Array.make nrNodes false in - let revResult = ref ([]) in - let predecessorsSet = Array.make nrNodes (IntSet.empty) in - for i = 0 to nrNodes -1 do - List.iter (fun s -> predecessorsSet.(s) <- IntSet.add i predecessorsSet.(s)) successors.(i); - done; - let predecessors = Array.init nrNodes (fun i -> set2list predecessorsSet.(i)) in - let workList = ref([]) in - for i = 0 to nrNodes - 1 do - if (predecessors.(i) = []) then workList := i::!workList; - done; - while (!workList != []) do - let x = List.hd !workList in - workList := List.tl !workList; - revResult := x::!revResult; - processed.(x) <- true; - List.iter (fun s -> - if (List.for_all (fun p -> processed.(p)) predecessors.(s)) then - workList := s::!workList; - ) successors.(x); - done; - List.rev !revResult - - -(* Muchnick Fig 7.12 *) -(* takes an SCC description as an input and returns prepares the appropriate SCC *) -let preorder (nrNodes: int) (successors: (int list) array) (r: int): oneSccInfo = - if debug then begin - ignore (E.log "Inside preorder \n"); - for i = 0 to nrNodes - 1 do - ignore (E.log "succ(%d) = %a" i (docList (fun i -> num i)) successors.(i)); - done; - end; - let i = ref(0) in - let j = ref(0) in - let pre = Array.make nrNodes (-1) in - let post = Array.make nrNodes (-1) in - let visit = Array.make nrNodes (false) in - let backEdges = ref ([]) in - let headers = ref(IntSet.empty) in - let rec depth_first_search_pp (x:int) = - visit.(x) <- true; - pre.(x) <- !j; - incr j; - List.iter (fun (y:int) -> - if (not visit.(y)) then - (depth_first_search_pp y) - else - if (post.(y) = -1) then begin - backEdges := (x,y)::!backEdges; - headers := IntSet.add y !headers; - end; - ) successors.(x); - post.(x) <- !i; - incr i; - in - depth_first_search_pp r; - let nodes = Array.make nrNodes (-1) in - for y = 0 to nrNodes - 1 do - if (pre.(y) != -1) then nodes.(pre.(y)) <- y; - done; - let nodeList = List.filter (fun i -> (i != -1)) (Array.to_list nodes) in - let result = { headers = set2list !headers; backEdges = !backEdges; nodes = nodeList; } in - result - - -exception Finished - - -let strong_components (f: cfgInfo) (debug: bool) = - let size = f.size in - let parent = Array.make size (-1) in - let color = Array.make size (-1) in - let finish = Array.make size (-1) in - let root = Array.make size (-1) in - -(* returns a list of SCC. Each SCC is a tuple of SCC root and SCC nodes *) - let dfs (successors: (int list) array) (order: int array) = - let time = ref(-1) in - let rec dfs_visit u = - color.(u) <- 1; - incr time; - (* d.(u) <- time; *) - List.iter (fun v -> - if color.(v) = 0 then (parent.(v) <- u; dfs_visit v) - ) successors.(u); - color.(u) <- 2; - incr time; - finish.(u) <- !time - in - for u = 0 to size - 1 do - color.(u) <- 0; (* white = 0, gray = 1, black = 2 *) - parent.(u) <- -1; (* nil = -1 *) - root.(u) <- 0; (* Is u a root? *) - done; - time := 0; - Array.iter (fun u -> - if (color.(u) = 0) then begin - root.(u) <- 1; - dfs_visit u; - end; - ) order; - in - - let simpleOrder = Array.init size (fun i -> i) in - dfs f.successors simpleOrder; - Array.sort (fun i j -> if (finish.(i) > finish.(j)) then -1 else 1) simpleOrder; - - dfs f.predecessors simpleOrder; -(* SCCs have been computed. (The trees represented by non-null parent edges - * represent the SCCS. We call the black nodes as the roots). Now put the - * result in the ouput format *) - let allScc = ref([]) in - for u = 0 to size - 1 do - if root.(u) = 1 then begin - let sccNodes = ref(IntSet.empty) in - let workList = ref([u]) in - while (!workList != []) do - let h=List.hd !workList in - workList := List.tl !workList; - sccNodes := IntSet.add h !sccNodes; - List.iter (fun s -> if parent.(s)=h then workList := s::!workList;) f.predecessors.(h); - done; - allScc := (u,!sccNodes)::!allScc; - if (debug) then begin - ignore (E.log "Got an SCC with root %d and nodes %a" u (docList num) (set2list !sccNodes)); - end; - end; - done; - !allScc - - -let stronglyConnectedComponents (f: cfgInfo) (debug: bool): sccInfo = - let size = f.size in - if (debug) then begin - ignore (E.log "size = %d\n" size); - for i = 0 to size - 1 do - ignore (E.log "Successors(%d): %a\n" i (docList (fun n -> num n)) f.successors.(i)); - done; - end; - - let allScc = strong_components f debug in - let all_sccArray = Array.of_list allScc in - - if (debug) then begin - ignore (E.log "Computed SCCs\n"); - for i = 0 to (Array.length all_sccArray) - 1 do - ignore(E.log "SCC #%d: " i); - let (_,sccNodes) = all_sccArray.(i) in - IntSet.iter (fun i -> ignore(E.log "%d, " i)) sccNodes; - ignore(E.log "\n"); - done; - end; - - - (* Construct sccId: Node -> Scc Id *) - let sccId = Array.make size (-1) in - Array.iteri (fun i (r,sccNodes) -> - IntSet.iter (fun n -> sccId.(n) <- i) sccNodes; - ) all_sccArray; - - if (debug) then begin - ignore (E.log "\nComputed SCC IDs: "); - for i = 0 to size - 1 do - ignore (E.log "SCCID(%d) = %d " i sccId.(i)); - done; - end; - - - (* Construct sccCFG *) - let nrScc = Array.length all_sccArray in - let successors = Array.make nrScc [] in - for x = 0 to nrScc - 1 do - successors.(x) <- - let s = ref(IntSet.empty) in - IntSet.iter (fun y -> - List.iter (fun z -> - let sy = sccId.(y) in - let sz = sccId.(z) in - if (not(sy = sz)) then begin - s := IntSet.add sz !s; - end - ) f.successors.(y) - ) (snd all_sccArray.(x)); - set2list !s - done; - - if (debug) then begin - ignore (E.log "\nComputed SCC CFG, which should be a DAG:"); - ignore (E.log "nrSccs = %d " nrScc); - for i = 0 to nrScc - 1 do - ignore (E.log "successors(%d) = [%a] " i (docList (fun j -> num j)) successors.(i)); - done; - end; - - - (* Order SCCs. The graph is a DAG here *) - let sccorder = preorderDAG nrScc successors in - - if (debug) then begin - ignore (E.log "\nComputed SCC Preorder: "); - ignore (E.log "Nodes in Preorder = [%a]" (docList (fun i -> num i)) sccorder); - end; - - (* Order nodes of each SCC. The graph is a SCC here.*) - let scclist = List.map (fun i -> - let successors = Array.create size [] in - for j = 0 to size - 1 do - successors.(j) <- List.filter (fun x -> IntSet.mem x (snd all_sccArray.(i))) f.successors.(j); - done; - preorder f.size successors (fst all_sccArray.(i)) - ) sccorder in - if (debug) then begin - ignore (E.log "Computed Preorder for Nodes of each SCC\n"); - List.iter (fun scc -> - ignore (E.log "BackEdges = %a \n" - (docList (fun (src,dest) -> dprintf "(%d,%d)" src dest)) - scc.backEdges);) - scclist; - end; - scclist - - - - - - - - - diff --git a/cil/src/ext/ssa.mli b/cil/src/ext/ssa.mli deleted file mode 100644 index be244d8..0000000 --- a/cil/src/ext/ssa.mli +++ /dev/null @@ -1,45 +0,0 @@ -type cfgInfo = { - name: string; (* The function name *) - start : int; - size : int; - blocks: cfgBlock array; (** Dominating blocks must come first *) - successors: int list array; (* block indices *) - predecessors: int list array; - mutable nrRegs: int; - mutable regToVarinfo: Cil.varinfo array; (** Map register IDs to varinfo *) - } - -(** A block corresponds to a statement *) -and cfgBlock = { - bstmt: Cil.stmt; - - (* We abstract the statement as a list of def/use instructions *) - instrlist: instruction list; - mutable livevars: (reg * int) list; - (** For each variable ID that is live at the start of the block, the - * block whose definition reaches this point. If that block is the same - * as the current one, then the variable is a phi variable *) - mutable reachable: bool; - } - -and instruction = (reg list * reg list) - (* lhs variables, variables on rhs. *) - - -and reg = int - -type idomInfo = int array (* immediate dominator *) - -and dfInfo = (int list) array (* dominance frontier *) - -and oneSccInfo = { - nodes: int list; - headers: int list; - backEdges: (int*int) list; - } - -and sccInfo = oneSccInfo list - -val add_ssa_info: cfgInfo -> unit -val stronglyConnectedComponents: cfgInfo -> bool -> sccInfo -val prune_cfg: cfgInfo -> cfgInfo diff --git a/cil/src/ext/stackoverflow.ml b/cil/src/ext/stackoverflow.ml deleted file mode 100644 index da2c401..0000000 --- a/cil/src/ext/stackoverflow.ml +++ /dev/null @@ -1,246 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -module H = Hashtbl -open Cil -open Pretty -module E = Errormsg - -let debug = false - - -(* For each function we have a node *) -type node = { name: string; - mutable scanned: bool; - mutable mustcheck: bool; - mutable succs: node list } -(* We map names to nodes *) -let functionNodes: (string, node) H.t = H.create 113 -let getFunctionNode (n: string) : node = - Util.memoize - functionNodes - n - (fun _ -> { name = n; mustcheck = false; scanned = false; succs = [] }) - -(** Dump the function call graph. Assume that there is a main *) -let dumpGraph = true -let dumpFunctionCallGraph () = - H.iter (fun _ x -> x.scanned <- false) functionNodes; - let rec dumpOneNode (ind: int) (n: node) : unit = - output_string !E.logChannel "\n"; - for i = 0 to ind do - output_string !E.logChannel " " - done; - output_string !E.logChannel (n.name ^ " "); - if n.scanned then (* Already dumped *) - output_string !E.logChannel " " - else begin - n.scanned <- true; - List.iter (dumpOneNode (ind + 1)) n.succs - end - in - try - let main = H.find functionNodes "main" in - dumpOneNode 0 main - with Not_found -> begin - ignore (E.log - "I would like to dump the function graph but there is no main"); - end - -(* We add a dummy function whose name is "@@functionPointer@@" that is called - * at all invocations of function pointers and itself calls all functions - * whose address is taken. *) -let functionPointerName = "@@functionPointer@@" - -let checkSomeFunctions = ref false - -let init () = - H.clear functionNodes; - checkSomeFunctions := false - - -let addCall (caller: string) (callee: string) = - let callerNode = getFunctionNode caller in - let calleeNode = getFunctionNode callee in - if not (List.exists (fun n -> n.name = callee) callerNode.succs) then begin - if debug then - ignore (E.log "found call from %s to %s\n" caller callee); - callerNode.succs <- calleeNode :: callerNode.succs; - end; - () - - -class findCallsVisitor (host: string) : cilVisitor = object - inherit nopCilVisitor - - method vinst i = - match i with - | Call(_,Lval(Var(vi),NoOffset),_,l) -> - addCall host vi.vname; - SkipChildren - - | Call(_,e,_,l) -> (* Calling a function pointer *) - addCall host functionPointerName; - SkipChildren - - | _ -> SkipChildren (* No calls in other instructions *) - - (* There are no calls in expressions and types *) - method vexpr e = SkipChildren - method vtype t = SkipChildren - -end - -(* Now detect the cycles in the call graph. Do a depth first search of the - * graph (stack is the list of nodes already visited in the current path). - * Return true if we have found a cycle. *) -let rec breakCycles (stack: node list) (n: node) : bool = - if n.scanned then (* We have already scanned this node. There are no cycles - * going through this node *) - false - else if n.mustcheck then - (* We are reaching a node that we already know we much check. Return with - * no new cycles. *) - false - else if List.memq n stack then begin - (* We have found a cycle. Mark the node n to be checked and return *) - if debug then - ignore (E.log "Will place an overflow check in %s\n" n.name); - checkSomeFunctions := true; - n.mustcheck <- true; - n.scanned <- true; - true - end else begin - let res = List.exists (fun nd -> breakCycles (n :: stack) nd) n.succs in - n.scanned <- true; - if res && n.mustcheck then - false - else - res - end -let findCheckPlacement () = - H.iter (fun _ nd -> - if nd.name <> functionPointerName - && not nd.scanned && not nd.mustcheck then begin - ignore (breakCycles [] nd) - end) - functionNodes - -let makeFunctionCallGraph (f: Cil.file) : unit = - init (); - (* Scan the file and construct the control-flow graph *) - List.iter - (function - GFun(fdec, _) -> - if fdec.svar.vaddrof then - addCall functionPointerName fdec.svar.vname; - let vis = new findCallsVisitor fdec.svar.vname in - ignore (visitCilBlock vis fdec.sbody) - - | _ -> ()) - f.globals - -let makeAndDumpFunctionCallGraph (f: file) = - makeFunctionCallGraph f; - dumpFunctionCallGraph () - - -let addCheck (f: Cil.file) : unit = - makeFunctionCallGraph f; - findCheckPlacement (); - if !checkSomeFunctions then begin - (* Add a declaration for the stack threshhold variable. The program is - * stopped when the stack top is less than this value. *) - let stackThreshholdVar = makeGlobalVar "___stack_threshhold" !upointType in - stackThreshholdVar.vstorage <- Extern; - (* And the initialization function *) - let computeStackThreshhold = - makeGlobalVar "___compute_stack_threshhold" - (TFun(!upointType, Some [], false, [])) in - computeStackThreshhold.vstorage <- Extern; - (* And the failure function *) - let stackOverflow = - makeGlobalVar "___stack_overflow" - (TFun(voidType, Some [], false, [])) in - stackOverflow.vstorage <- Extern; - f.globals <- - GVar(stackThreshholdVar, {init=None}, locUnknown) :: - GVarDecl(computeStackThreshhold, locUnknown) :: - GVarDecl(stackOverflow, locUnknown) :: f.globals; - (* Now scan and instrument each function definition *) - List.iter - (function - GFun(fdec, l) -> - (* If this is main we must introduce the initialization of the - * bottomOfStack *) - let nd = getFunctionNode fdec.svar.vname in - if fdec.svar.vname = "main" then begin - if nd.mustcheck then - E.s (E.error "The \"main\" function is recursive!!"); - let loc = makeLocalVar fdec "__a_local" intType in - loc.vaddrof <- true; - fdec.sbody <- - mkBlock - [ mkStmtOneInstr - (Call (Some(var stackThreshholdVar), - Lval(var computeStackThreshhold), [], l)); - mkStmt (Block fdec.sbody) ] - end else if nd.mustcheck then begin - let loc = makeLocalVar fdec "__a_local" intType in - loc.vaddrof <- true; - fdec.sbody <- - mkBlock - [ mkStmt - (If(BinOp(Le, - CastE(!upointType, AddrOf (var loc)), - Lval(var stackThreshholdVar), intType), - mkBlock [mkStmtOneInstr - (Call(None, Lval(var stackOverflow), - [], l))], - mkBlock [], - l)); - mkStmt (Block fdec.sbody) ] - end else - () - - | _ -> ()) - f.globals; - () - end - - - - diff --git a/cil/src/ext/stackoverflow.mli b/cil/src/ext/stackoverflow.mli deleted file mode 100644 index 6ec0200..0000000 --- a/cil/src/ext/stackoverflow.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* This module inserts code to check for stack overflow. It saves the address - * of the top of the stack in "main" and then it picks one function *) - -val addCheck: Cil.file -> unit - -val makeAndDumpFunctionCallGraph: Cil.file -> unit diff --git a/cil/src/ext/usedef.ml b/cil/src/ext/usedef.ml deleted file mode 100755 index 57f226a..0000000 --- a/cil/src/ext/usedef.ml +++ /dev/null @@ -1,188 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - - -open Cil -open Pretty - -(** compute use/def information *) - -module VS = Set.Make (struct - type t = Cil.varinfo - let compare v1 v2 = Pervasives.compare v1.vid v2.vid - end) - -(** Set this global to how you want to handle function calls *) -let getUseDefFunctionRef: (exp -> VS.t * VS.t) ref = - ref (fun _ -> (VS.empty, VS.empty)) - -(** Say if you want to consider a variable use *) -let considerVariableUse: (varinfo -> bool) ref = - ref (fun _ -> true) - - -(** Say if you want to consider a variable def *) -let considerVariableDef: (varinfo -> bool) ref = - ref (fun _ -> true) - -(** Save if you want to consider a variable addrof as a use *) -let considerVariableAddrOfAsUse: (varinfo -> bool) ref = - ref (fun _ -> true) - -(* When this is true, only definitions of a variable without - an offset are counted as definitions. So: - a = 5; would be a definition, but - a[1] = 5; would not *) -let onlyNoOffsetsAreDefs: bool ref = ref false - -let varUsed: VS.t ref = ref VS.empty -let varDefs: VS.t ref = ref VS.empty - -class useDefVisitorClass : cilVisitor = object (self) - inherit nopCilVisitor - - (** this will be invoked on variable definitions only because we intercept - * all uses of variables in expressions ! *) - method vvrbl (v: varinfo) = - if (!considerVariableDef) v && - not(!onlyNoOffsetsAreDefs) then - varDefs := VS.add v !varDefs; - SkipChildren - - (** If onlyNoOffsetsAreDefs is true, then we need to see the - * varinfo in an lval along with the offset. Otherwise just - * DoChildren *) - method vlval (l: lval) = - if !onlyNoOffsetsAreDefs then - match l with - (Var vi, NoOffset) -> - if (!considerVariableDef) vi then - varDefs := VS.add vi !varDefs; - SkipChildren - | _ -> DoChildren - else DoChildren - - method vexpr = function - Lval (Var v, off) -> - ignore (visitCilOffset (self :> cilVisitor) off); - if (!considerVariableUse) v then - varUsed := VS.add v !varUsed; - SkipChildren (* So that we do not see the v *) - - | AddrOf (Var v, off) - | StartOf (Var v, off) -> - ignore (visitCilOffset (self :> cilVisitor) off); - if (!considerVariableAddrOfAsUse) v then - varUsed := VS.add v !varUsed; - SkipChildren - - | _ -> DoChildren - - (* For function calls, do the transitive variable read/defs *) - method vinst = function - Call (_, f, _, _) -> begin - (* we will call DoChildren to compute the use and def that appear in - * this instruction. We also add in the stuff computed by - * getUseDefFunctionRef *) - let use, def = !getUseDefFunctionRef f in - varUsed := VS.union !varUsed use; - varDefs := VS.union !varDefs def; - DoChildren; - end - | Asm(_,_,slvl,_,_,_) -> List.iter (fun (s,lv) -> - match lv with (Var v, off) -> - if s.[0] = '+' then - varUsed := VS.add v !varUsed; - | _ -> ()) slvl; - DoChildren - | _ -> DoChildren - -end - -let useDefVisitor = new useDefVisitorClass - -(** Compute the use information for an expression (accumulate to an existing - * set) *) -let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t = - varUsed := acc; - ignore (visitCilExpr useDefVisitor e); - !varUsed - - -(** Compute the use/def information for an instruction *) -let computeUseDefInstr ?(acc_used=VS.empty) - ?(acc_defs=VS.empty) - (i: instr) : VS.t * VS.t = - varUsed := acc_used; - varDefs := acc_defs; - ignore (visitCilInstr useDefVisitor i); - !varUsed, !varDefs - - -(** Compute the use/def information for a statement kind. Do not descend into - * the nested blocks. *) -let computeUseDefStmtKind ?(acc_used=VS.empty) - ?(acc_defs=VS.empty) - (sk: stmtkind) : VS.t * VS.t = - varUsed := acc_used; - varDefs := acc_defs; - let ve e = ignore (visitCilExpr useDefVisitor e) in - let _ = - match sk with - Return (None, _) -> () - | Return (Some e, _) -> ve e - | If (e, _, _, _) -> ve e - | Break _ | Goto _ | Continue _ -> () -(* - | Loop (_, _, _, _) -> () -*) - | While _ | DoWhile _ | For _ -> () - | Switch (e, _, _, _) -> ve e - | Instr il -> - List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il - | TryExcept _ | TryFinally _ -> () - | Block _ -> () - in - !varUsed, !varDefs - -(* Compute the use/def information for a statement kind. - DO descend into nested blocks *) -let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty) - ?(acc_defs=VS.empty) - (sk: stmtkind) : VS.t * VS.t = - let handle_block b = - List.fold_left (fun (u,d) s -> - let u',d' = computeDeepUseDefStmtKind s.skind in - (VS.union u u', VS.union d d')) (VS.empty, VS.empty) - b.bstmts - in - varUsed := acc_used; - varDefs := acc_defs; - let ve e = ignore (visitCilExpr useDefVisitor e) in - match sk with - Return (None, _) -> !varUsed, !varDefs - | Return (Some e, _) -> - let _ = ve e in - !varUsed, !varDefs - | If (e, tb, fb, _) -> - let _ = ve e in - let u, d = !varUsed, !varDefs in - let u', d' = handle_block tb in - let u'', d'' = handle_block fb in - (VS.union (VS.union u u') u'', VS.union (VS.union d d') d'') - | Break _ | Goto _ | Continue _ -> !varUsed, !varDefs -(* - | Loop (b, _, _, _) -> handle_block b -*) - | While (_, b, _) -> handle_block b - | DoWhile (_, b, _) -> handle_block b - | For (_, _, _, b, _) -> handle_block b - | Switch (e, b, _, _) -> - let _ = ve e in - let u, d = !varUsed, !varDefs in - let u', d' = handle_block b in - (VS.union u u', VS.union d d') - | Instr il -> - List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il; - !varUsed, !varDefs - | TryExcept _ | TryFinally _ -> !varUsed, !varDefs - | Block b -> handle_block b diff --git a/cil/src/formatcil.ml b/cil/src/formatcil.ml deleted file mode 100644 index 33bc749..0000000 --- a/cil/src/formatcil.ml +++ /dev/null @@ -1,215 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -open Cil -open Pretty -open Trace (* sm: 'trace' function *) -module E = Errormsg -module H = Hashtbl - -let noMemoize = ref false - -let expMemoTable : - (string, (((string * formatArg) list -> exp) * - (exp -> formatArg list option))) H.t = H.create 23 - -let typeMemoTable : - (string, (((string * formatArg) list -> typ) * - (typ -> formatArg list option))) H.t = H.create 23 - -let lvalMemoTable : - (string, (((string * formatArg) list -> lval) * - (lval -> formatArg list option))) H.t = H.create 23 - -let instrMemoTable : - (string, ((location -> (string * formatArg) list -> instr) * - (instr -> formatArg list option))) H.t = H.create 23 - -let stmtMemoTable : - (string, ((string -> typ -> varinfo) -> - location -> - (string * formatArg) list -> stmt)) H.t = H.create 23 - -let stmtsMemoTable : - (string, ((string -> typ -> varinfo) -> - location -> - (string * formatArg) list -> stmt list)) H.t = H.create 23 - - -let doParse (prog: string) - (theParser: (Lexing.lexbuf -> Formatparse.token) - -> Lexing.lexbuf -> 'a) - (memoTable: (string, 'a) H.t) : 'a = - try - if !noMemoize then raise Not_found else - H.find memoTable prog - with Not_found -> begin - let lexbuf = Formatlex.init prog in - try - Formatparse.initialize Formatlex.initial lexbuf; - let res = theParser Formatlex.initial lexbuf in - H.add memoTable prog res; - Formatlex.finish (); - res - with Parsing.Parse_error -> begin - Formatlex.finish (); - E.s (E.error "Parsing error: %s" prog) - end - | e -> begin - ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e)); - Formatlex.finish (); - raise e - end - end - - -let cExp (prog: string) : (string * formatArg) list -> exp = - let cf = doParse prog Formatparse.expression expMemoTable in - (fst cf) - -let cLval (prog: string) : (string * formatArg) list -> lval = - let cf = doParse prog Formatparse.lval lvalMemoTable in - (fst cf) - -let cType (prog: string) : (string * formatArg) list -> typ = - let cf = doParse prog Formatparse.typename typeMemoTable in - (fst cf) - -let cInstr (prog: string) : location -> (string * formatArg) list -> instr = - let cf = doParse prog Formatparse.instr instrMemoTable in - (fst cf) - -let cStmt (prog: string) : (string -> typ -> varinfo) -> - location -> (string * formatArg) list -> stmt = - let cf = doParse prog Formatparse.stmt stmtMemoTable in - cf - -let cStmts (prog: string) : - (string -> typ -> varinfo) -> - location -> (string * formatArg) list -> stmt list = - let cf = doParse prog Formatparse.stmt_list stmtsMemoTable in - cf - - - -(* Match an expression *) -let dExp (prog: string) : exp -> formatArg list option = - let df = doParse prog Formatparse.expression expMemoTable in - (snd df) - -(* Match an lvalue *) -let dLval (prog: string) : lval -> formatArg list option = - let df = doParse prog Formatparse.lval lvalMemoTable in - (snd df) - - -(* Match a type *) -let dType (prog: string) : typ -> formatArg list option = - let df = doParse prog Formatparse.typename typeMemoTable in - (snd df) - - - -(* Match an instruction *) -let dInstr (prog: string) : instr -> formatArg list option = - let df = doParse prog Formatparse.instr instrMemoTable in - (snd df) - - -let test () = - (* Construct a dummy function *) - let func = emptyFunction "test_formatcil" in - (* Construct a few varinfo *) - let res = makeLocalVar func "res" (TPtr(intType, [])) in - let fptr = makeLocalVar func "fptr" - (TPtr(TFun(intType, None, false, []), [])) in - (* Construct an instruction *) - let makeInstr () = - Call(Some (var res), - Lval (Mem (CastE(TPtr(TFun(TPtr(intType, []), - Some [ ("", intType, []); - ("a2", TPtr(intType, []), []); - ("a3", TPtr(TPtr(intType, []), - []), []) ], - false, []), []), - Lval (var fptr))), - NoOffset), - [ ], locUnknown) - in - let times = 100000 in - (* Make the instruction the regular way *) - Stats.time "make instruction regular" - (fun _ -> for i = 0 to times do ignore (makeInstr ()) done) - (); - (* Now make the instruction interpreted *) - noMemoize := true; - Stats.time "make instruction interpreted" - (fun _ -> for i = 0 to times do - let _ = - cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" - locUnknown [ ("res", Fv res); - ("fptr", Fv fptr) ] - in - () - done) - (); - (* Now make the instruction interpreted with memoization *) - noMemoize := false; - Stats.time "make instruction interpreted memoized" - (fun _ -> for i = 0 to times do - let _ = - cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" - locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] - in - () - done) - (); - (* Now make the instruction interpreted with partial application *) - let partInstr = - cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" in - Stats.time "make instruction interpreted partial" - (fun _ -> for i = 0 to times do - let _ = - partInstr - locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] - in - () - done) - (); - - () - - diff --git a/cil/src/formatcil.mli b/cil/src/formatcil.mli deleted file mode 100644 index d353c5e..0000000 --- a/cil/src/formatcil.mli +++ /dev/null @@ -1,103 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(** {b An Interpreter for constructing CIL constructs} *) - - -(** Constructs an expression based on the program and the list of arguments. - * Each argument consists of a name followed by the actual data. This - * argument will be placed instead of occurrences of "%v:name" in the pattern - * (where the "v" is dependent on the type of the data). The parsing of the - * string is memoized. * Only the first expression is parsed. *) -val cExp: string -> (string * Cil.formatArg) list -> Cil.exp - -(** Constructs an lval based on the program and the list of arguments. - * Only the first lvalue is parsed. - * The parsing of the string is memoized. *) -val cLval: string -> (string * Cil.formatArg) list -> Cil.lval - -(** Constructs a type based on the program and the list of arguments. - * Only the first type is parsed. - * The parsing of the string is memoized. *) -val cType: string -> (string * Cil.formatArg) list -> Cil.typ - - -(** Constructs an instruction based on the program and the list of arguments. - * Only the first instruction is parsed. - * The parsing of the string is memoized. *) -val cInstr: string -> Cil.location -> - (string * Cil.formatArg) list -> Cil.instr - -(* Constructs a statement based on the program and the list of arguments. We - * also pass a function that can be used to make new varinfo's for the - * declared variables, and a location to be used for the statements. Only the - * first statement is parsed. The parsing of the string is memoized. *) -val cStmt: string -> - (string -> Cil.typ -> Cil.varinfo) -> - Cil.location -> (string * Cil.formatArg) list -> Cil.stmt - -(** Constructs a list of statements *) -val cStmts: string -> - (string -> Cil.typ -> Cil.varinfo) -> - Cil.location -> (string * Cil.formatArg) list -> - Cil.stmt list - -(** Deconstructs an expression based on the program. Produces an optional - * list of format arguments. The parsing of the string is memoized. *) -val dExp: string -> Cil.exp -> Cil.formatArg list option - -(** Deconstructs an lval based on the program. Produces an optional - * list of format arguments. The parsing of the string is memoized. *) -val dLval: string -> Cil.lval -> Cil.formatArg list option - - -(** Deconstructs a type based on the program. Produces an optional list of - * format arguments. The parsing of the string is memoized. *) -val dType: string -> Cil.typ -> Cil.formatArg list option - - -(** Deconstructs an instruction based on the program. Produces an optional - * list of format arguments. The parsing of the string is memoized. *) -val dInstr: string -> Cil.instr -> Cil.formatArg list option - - -(** If set then will not memoize the parsed patterns *) -val noMemoize: bool ref - -(** Just a testing function *) -val test: unit -> unit diff --git a/cil/src/formatlex.mll b/cil/src/formatlex.mll deleted file mode 100644 index 584a060..0000000 --- a/cil/src/formatlex.mll +++ /dev/null @@ -1,308 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(* A simple lexical analyzer for constructing CIL based on format strings *) -{ -open Formatparse -exception Eof -exception InternalError of string -module H = Hashtbl -module E = Errormsg -(* -** Keyword hashtable -*) -let keywords = H.create 211 - -(* -** Useful primitives -*) -let scan_ident id = - try H.find keywords id - with Not_found -> IDENT id (* default to variable name *) - -(* -** Buffer processor -*) - - -let init ~(prog: string) : Lexing.lexbuf = - H.clear keywords; - Lexerhack.currentPattern := prog; - List.iter - (fun (key, token) -> H.add keywords key token) - [ ("const", CONST); ("__const", CONST); ("__const__", CONST); - ("static", STATIC); - ("extern", EXTERN); - ("long", LONG); - ("short", SHORT); - ("signed", SIGNED); - ("unsigned", UNSIGNED); - ("volatile", VOLATILE); - ("char", CHAR); - ("int", INT); - ("float", FLOAT); - ("double", DOUBLE); - ("void", VOID); - ("enum", ENUM); - ("struct", STRUCT); - ("typedef", TYPEDEF); - ("union", UNION); - ("break", BREAK); - ("continue", CONTINUE); - ("goto", GOTO); - ("return", RETURN); - ("switch", SWITCH); - ("case", CASE); - ("default", DEFAULT); - ("while", WHILE); - ("do", DO); - ("for", FOR); - ("if", IF); - ("else", ELSE); - ("__attribute__", ATTRIBUTE); ("__attribute", ATTRIBUTE); - ("__int64", INT64); - ("__builtin_va_arg", BUILTIN_VA_ARG); - ]; - E.startParsingFromString prog - -let finish () = - E.finishParsing () - -(*** Error handling ***) -let error msg = - E.parse_error msg - - -(*** escape character management ***) -let scan_escape str = - match str with - "n" -> "\n" - | "r" -> "\r" - | "t" -> "\t" - | "b" -> "\b" - | "f" -> "\012" (* ASCII code 12 *) - | "v" -> "\011" (* ASCII code 11 *) - | "a" -> "\007" (* ASCII code 7 *) - | "e" -> "\027" (* ASCII code 27. This is a GCC extension *) - | _ -> str - -let get_value chr = - match chr with - '0'..'9' -> (Char.code chr) - (Char.code '0') - | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10 - | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10 - | _ -> 0 -let scan_hex_escape str = - String.make 1 (Char.chr ( - (get_value (String.get str 0)) * 16 - + (get_value (String.get str 1)) - )) -let scan_oct_escape str = - (* weimer: wide-character constants like L'\400' may be bigger than - * 256 (in fact, may be up to 511), so Char.chr cannot be used directly *) - let the_value = (get_value (String.get str 0)) * 64 - + (get_value (String.get str 1)) * 8 - + (get_value (String.get str 2)) in - if the_value < 256 then String.make 1 (Char.chr the_value ) - else (String.make 1 (Char.chr (the_value / 256))) ^ - (String.make 1 (Char.chr (the_value mod 256))) - -(* ISO standard locale-specific function to convert a wide character - * into a sequence of normal characters. Here we work on strings. - * We convert L"Hi" to "H\000i\000" *) -let wbtowc wstr = - let len = String.length wstr in - let dest = String.make (len * 2) '\000' in - for i = 0 to len-1 do - dest.[i*2] <- wstr.[i] ; - done ; - dest - -(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } *) -let wstr_to_warray wstr = - let len = String.length wstr in - let res = ref "{ " in - for i = 0 to len-1 do - res := !res ^ (Printf.sprintf "L'%c', " wstr.[i]) - done ; - res := !res ^ "}" ; - !res - -let getArgName (l: Lexing.lexbuf) (prefixlen: int) = - let lexeme = Lexing.lexeme l in - let ll = String.length lexeme in - if ll > prefixlen then - String.sub lexeme (prefixlen + 1) (ll - prefixlen - 1) - else - "" -} - -let decdigit = ['0'-'9'] -let octdigit = ['0'-'7'] -let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] -let letter = ['a'- 'z' 'A'-'Z'] - -let floatsuffix = ['f' 'F' 'l' 'L'] - -let usuffix = ['u' 'U'] -let lsuffix = "l"|"L"|"ll"|"LL" -let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix - -let intnum = decdigit+ intsuffix? -let octnum = '0' octdigit+ intsuffix? -let hexnum = '0' ['x' 'X'] hexdigit+ intsuffix? - -let exponent = ['e' 'E']['+' '-']? decdigit+ -let fraction = '.' decdigit+ -let floatraw = (intnum? fraction) - |(intnum exponent) - |(intnum? fraction exponent) - |(intnum '.') - |(intnum '.' exponent) -let floatnum = floatraw floatsuffix? - -let ident = (letter|'_')(letter|decdigit|'_')* -let attribident = (letter|'_')(letter|decdigit|'_'|':') -let blank = [' ' '\t' '\012' '\r'] -let escape = '\\' _ -let hex_escape = '\\' ['x' 'X'] hexdigit hexdigit -let oct_escape = '\\' octdigit octdigit octdigit - - -(* The arguments are of the form %l:foo *) -let argname = ':' ident - -rule initial = - parse blank { initial lexbuf} -| "/*" { let _ = comment lexbuf in - initial lexbuf} -| "//" { endline lexbuf } -| "\n" { E.newline (); initial lexbuf} -| floatnum {CST_FLOAT (Lexing.lexeme lexbuf)} -| hexnum {CST_INT (Lexing.lexeme lexbuf)} -| octnum {CST_INT (Lexing.lexeme lexbuf)} -| intnum {CST_INT (Lexing.lexeme lexbuf)} - -| "<<=" {INF_INF_EQ} -| ">>=" {SUP_SUP_EQ} -| "*=" {STAR_EQ} -| "/=" {SLASH_EQ} -| "&=" {AND_EQ} -| "|=" {PIPE_EQ} -| "^=" {CIRC_EQ} -| "%=" {PERCENT_EQ} - - -| "..." {ELLIPSIS} -| "-=" {MINUS_EQ} -| "+=" {PLUS_EQ} -| "*=" {STAR_EQ} -| "<<" {INF_INF} -| ">>" {SUP_SUP} -| "==" {EQ_EQ} -| "!=" {EXCLAM_EQ} -| "<=" {INF_EQ} -| ">=" {SUP_EQ} -| "=" {EQ} -| "<" {INF} -| ">" {SUP} -| "++" {PLUS_PLUS} -| "--" {MINUS_MINUS} -| "->" {ARROW} -| '+' {PLUS} -| '-' {MINUS} -| '*' {STAR} -| '/' {SLASH} -| '!' {EXCLAM} -| '&' {AND} -| '|' {PIPE} -| '^' {CIRC} -| '~' {TILDE} -| '[' {LBRACKET} -| ']' {RBRACKET} -| '{' {LBRACE} -| '}' {RBRACE} -| '(' {LPAREN} -| ')' {RPAREN} -| ';' {SEMICOLON} -| ',' {COMMA} -| '.' {DOT} -| ':' {COLON} -| '?' {QUEST} -| "sizeof" {SIZEOF} - -| "%eo" argname {ARG_eo (getArgName lexbuf 3) } -| "%e" argname {ARG_e (getArgName lexbuf 2) } -| "%E" argname {ARG_E (getArgName lexbuf 2) } -| "%u" argname {ARG_u (getArgName lexbuf 2) } -| "%b" argname {ARG_b (getArgName lexbuf 2) } -| "%t" argname {ARG_t (getArgName lexbuf 2) } -| "%d" argname {ARG_d (getArgName lexbuf 2) } -| "%lo" argname {ARG_lo (getArgName lexbuf 3) } -| "%l" argname {ARG_l (getArgName lexbuf 2) } -| "%i" argname {ARG_i (getArgName lexbuf 2) } -| "%I" argname {ARG_I (getArgName lexbuf 2) } -| "%o" argname {ARG_o (getArgName lexbuf 2) } -| "%va" argname {ARG_va (getArgName lexbuf 3) } -| "%v" argname {ARG_v (getArgName lexbuf 2) } -| "%k" argname {ARG_k (getArgName lexbuf 2) } -| "%f" argname {ARG_f (getArgName lexbuf 2) } -| "%F" argname {ARG_F (getArgName lexbuf 2) } -| "%p" argname {ARG_p (getArgName lexbuf 2) } -| "%P" argname {ARG_P (getArgName lexbuf 2) } -| "%s" argname {ARG_s (getArgName lexbuf 2) } -| "%S" argname {ARG_S (getArgName lexbuf 2) } -| "%g" argname {ARG_g (getArgName lexbuf 2) } -| "%A" argname {ARG_A (getArgName lexbuf 2) } -| "%c" argname {ARG_c (getArgName lexbuf 2) } - -| '%' {PERCENT} -| ident {scan_ident (Lexing.lexeme lexbuf)} -| eof {EOF} -| _ {E.parse_error - "Formatlex: Invalid symbol" - } - -and comment = - parse - "*/" { () } -| '\n' { E.newline (); comment lexbuf } -| _ { comment lexbuf } - - -and endline = parse - '\n' { E.newline (); initial lexbuf} -| _ { endline lexbuf} diff --git a/cil/src/formatparse.mly b/cil/src/formatparse.mly deleted file mode 100644 index 75bdbb3..0000000 --- a/cil/src/formatparse.mly +++ /dev/null @@ -1,1455 +0,0 @@ -/* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. */ - -/*(* Parser for constructing CIL from format strings *) -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -*/ -%{ -open Cil -open Pretty -module E = Errormsg - -let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *) - E.hadErrors := true; - E.parse_error - msg - - -let getArg (argname: string) (args: (string * formatArg) list) = - try - snd (List.find (fun (n, a) -> n = argname) args) - with _ -> - E.s (error "Pattern string %s does not have argument with name %s\n" - !Lexerhack.currentPattern argname) - -let wrongArgType (which: string) (expected: string) (found: formatArg) = - E.s (bug "Expecting %s argument (%s) and found %a\n" - expected which d_formatarg found) - -let doUnop (uo: unop) subexp = - ((fun args -> - let e = (fst subexp) args in - UnOp(uo, e, typeOf e)), - - (fun e -> match e with - UnOp(uo', e', _) when uo = uo' -> (snd subexp) e' - | _ -> None)) - -let buildPlus e1 e2 : exp = - let t1 = typeOf e1 in - if isPointerType t1 then - BinOp(PlusPI, e1, e2, t1) - else - BinOp(PlusA, e1, e2, t1) - -let buildMinus e1 e2 : exp = - let t1 = typeOf e1 in - let t2 = typeOf e2 in - if isPointerType t1 then - if isPointerType t2 then - BinOp(MinusPP, e1, e2, intType) - else - BinOp(MinusPI, e1, e2, t1) - else - BinOp(MinusA, e1, e2, t1) - -let doBinop bop e1t e2t = - ((fun args -> - let e1 = (fst e1t) args in - let e2 = (fst e2t) args in - let t1 = typeOf e1 in - BinOp(bop, e1, e2, t1)), - - (fun e -> match e with - BinOp(bop', e1, e2, _) when bop' = bop -> begin - match (snd e1t) e1, (snd e2t) e2 with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - -(* Check the equivalence of two format lists *) -let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) = - match fl1, fl2 with - [], [] -> true - | h1::t1, h2::t2 -> begin - let rec checkOffsetEq o1 o2 = - match o1, o2 with - NoOffset, NoOffset -> true - | Field(f1, o1'), Field(f2, o2') -> - f1.fname = f2.fname && checkOffsetEq o1' o2' - | Index(e1, o1'), Index(e2, o2') -> - checkOffsetEq o1' o2' && checkExpEq e1 e2 - | _, _ -> false - - and checkExpEq e1 e2 = - match e1, e2 with - Const(CInt64(n1, _, _)), Const(CInt64(n2, _, _)) -> n1 = n2 - | Lval l1, Lval l2 -> checkLvalEq l1 l2 - | UnOp(uo1, e1, _), UnOp(uo2, e2, _) -> - uo1 = uo2 && checkExpEq e1 e2 - | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) -> - bo1 = bo2 && checkExpEq e11 e21 && checkExpEq e21 e22 - | AddrOf l1, AddrOf l2 -> checkLvalEq l1 l2 - | StartOf l1, StartOf l2 -> checkLvalEq l1 l2 - | SizeOf t1, SizeOf t2 -> typeSig t1 = typeSig t2 - | _, _ -> - ignore (E.warn "checkSameFormat for Fe"); false - - and checkLvalEq l1 l2 = - match l1, l2 with - (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2 - | (Mem e1, o1), (Mem e2, o2) -> - checkOffsetEq o1 o2 && checkExpEq e1 e2 - | _, _ -> false - in - let hdeq = - match h1, h2 with - Fv v1, Fv v2 -> v1 == v2 - | Fd n1, Fd n2 -> n1 = n2 - | Fe e1, Fe e2 -> checkExpEq e1 e2 - | Fi i1, Fi i2 -> ignore (E.warn "checkSameFormat for Fi"); false - | Ft t1, Ft t2 -> typeSig t1 = typeSig t2 - | Fl l1, Fl l2 -> checkLvalEq l1 l2 - | Fo o1, Fo o2 -> checkOffsetEq o1 o2 - | Fc c1, Fc c2 -> c1 == c2 - | _, _ -> false - in - hdeq || checkSameFormat t1 t2 - end - | _, _ -> false - -let matchBinopEq (bopeq: binop -> bool) lvt et = - (fun i -> match i with - Set (lv, BinOp(bop', Lval (lv'), e', _), l) when bopeq bop' -> begin - match lvt lv, lvt lv', et e' with - Some m1, Some m1', Some m2 -> - (* Must check that m1 and m2 are the same *) - if checkSameFormat m1 m1' then - Some (m1 @ m2) - else - None - | _, _, _ -> None - end - | _ -> None) - -let doBinopEq bop lvt et = - ((fun loc args -> - let l = (fst lvt) args in - Set(l, BinOp(bop, (Lval l), (fst et) args, typeOfLval l), loc)), - - matchBinopEq (fun bop' -> bop = bop') (snd lvt) (snd et)) - - -let getField (bt: typ) (fname: string) : fieldinfo = - match unrollType bt with - TComp(ci, _) -> begin - try - List.find (fun f -> fname = f.fname) ci.cfields - with Not_found -> - E.s (bug "Cannot find field %s in %s\n" fname (compFullName ci)) - end - | t -> E.s (bug "Trying to access field %s in non-struct\n" fname) - - -let matchIntType (ik: ikind) (t:typ) : formatArg list option = - match unrollType t with - TInt(ik', _) when ik = ik' -> Some [] - | _ -> None - -let matchFloatType (fk: fkind) (t:typ) : formatArg list option = - match unrollType t with - TFloat(fk', _) when fk = fk' -> Some [] - | _ -> None - -let doAttr (id: string) - (aargs: (((string * formatArg) list -> attrparam list) * - (attrparam list -> formatArg list option)) option) - = - let t = match aargs with - Some t -> t - | None -> (fun _ -> []), - (function [] -> Some [] | _ -> None) - in - ((fun args -> Attr (id, (fst t) args)), - - (fun attrs -> - (* Find the attributes with the same ID *) - List.fold_left - (fun acc a -> - match acc, a with - Some _, _ -> acc (* We found one already *) - | None, Attr(id', args) when id = id' -> - (* Now match the arguments *) - (snd t) args - | None, _ -> acc) - None - attrs)) - - -type falist = formatArg list - -type maybeInit = - NoInit - | InitExp of exp - | InitCall of lval * exp list - -%} - -%token IDENT -%token CST_CHAR -%token CST_INT -%token CST_FLOAT -%token CST_STRING -%token CST_WSTRING -%token NAMED_TYPE - -%token EOF -%token CHAR INT DOUBLE FLOAT VOID INT64 INT32 -%token ENUM STRUCT TYPEDEF UNION -%token SIGNED UNSIGNED LONG SHORT -%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER - -%token ARG_e ARG_eo ARG_E ARG_u ARG_b ARG_t ARG_d ARG_lo ARG_l ARG_i -%token ARG_o ARG_va ARG_f ARG_F ARG_A ARG_v ARG_k ARG_c ARG_d -%token ARG_s ARG_p ARG_P ARG_I ARG_S ARG_g - -%token SIZEOF ALIGNOF - -%token EQ -%token ARROW DOT - -%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ -%token MINUS_EQ PLUS_EQ STAR_EQ -%token PLUS MINUS STAR SLASH PERCENT -%token TILDE AND PIPE CIRC -%token EXCLAM AND_AND PIPE_PIPE -%token INF_INF SUP_SUP -%token PLUS_PLUS MINUS_MINUS - -%token RPAREN LPAREN RBRACE LBRACE LBRACKET RBRACKET -%token COLON SEMICOLON COMMA ELLIPSIS QUEST - -%token BREAK CONTINUE GOTO RETURN -%token SWITCH CASE DEFAULT -%token WHILE DO FOR -%token IF THEN ELSE - -%token PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ -%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ - -%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ LABEL__ -%token BUILTIN_VA_ARG BUILTIN_VA_LIST -%token BLOCKATTRIBUTE -%token DECLSPEC -%token MSASM MSATTR -%token PRAGMA - - -/* operator precedence */ -%nonassoc IF -%nonassoc ELSE - - -%left COMMA - - /*(* Set the following precedences higer than COMMA *)*/ -%nonassoc ARG_e ARG_d ARG_lo ARG_l ARG_i ARG_v ARG_I ARG_g -%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ - AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ -%right COLON -%left PIPE_PIPE -%left AND_AND -%left ARG_b -%left PIPE -%left CIRC -%left AND -%left EQ_EQ EXCLAM_EQ -%left INF SUP INF_EQ SUP_EQ -%left INF_INF SUP_SUP -%left PLUS MINUS -%left STAR SLASH PERCENT CONST RESTRICT VOLATILE -%right ARG_u EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF -%left LBRACKET -%left DOT ARROW LPAREN LBRACE -%nonassoc IDENT QUEST CST_INT - -%start initialize expression typename offset lval instr stmt stmt_list - - -%type initialize -%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt)> stmt -%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list)> stmt_list - -%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> expression - -%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> constant - -%type <((string * Cil.formatArg) list -> Cil.lval) * (Cil.lval -> Cil.formatArg list option)> lval - -%type <((string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> typename - -%type <(Cil.attributes -> (string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> type_spec - -%type <((string * Cil.formatArg) list -> (string * Cil.typ * Cil.attributes) list option * bool) * ((string * Cil.typ * Cil.attributes) list option * bool -> Cil.formatArg list option)> parameters - - -%type <(Cil.location -> (string * Cil.formatArg) list -> Cil.instr) * (Cil.instr -> Cil.formatArg list option)> instr - -%type <(Cil.typ -> (string * Cil.formatArg) list -> Cil.offset) * (Cil.offset -> Cil.formatArg list option)> offset - - -%% - - -initialize: - /* empty */ { } -; - -/* (*** Expressions ***) */ - - -expression: -| ARG_e { (* Count arguments eagerly *) - let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fe e -> e - | a -> wrongArgType currentArg - "expression" a), - - (fun e -> Some [ Fe e ])) - } - -| constant { $1 } - -| lval %prec IDENT - { ((fun args -> Lval ((fst $1) args)), - - (fun e -> match e with - Lval l -> (snd $1) l - | _ -> None)) - } - -| SIZEOF expression - { ((fun args -> SizeOfE ((fst $2) args)), - - fun e -> match e with - SizeOfE e' -> (snd $2) e' - | _ -> None) - } - -| SIZEOF LPAREN typename RPAREN - { ((fun args -> SizeOf ((fst $3) args)), - - (fun e -> match e with - SizeOf t -> (snd $3) t - | _ -> None)) - } - -| ALIGNOF expression - { ((fun args -> AlignOfE ((fst $2) args)), - - (fun e -> match e with - AlignOfE e' -> (snd $2) e' | _ -> None)) - } - -| ALIGNOF LPAREN typename RPAREN - { ((fun args -> AlignOf ((fst $3) args)), - - (fun e -> match e with - AlignOf t' -> (snd $3) t' | _ -> None)) - } - -| PLUS expression - { $2 } -| MINUS expression - { doUnop Neg $2 } - -| EXCLAM expression - { doUnop LNot $2 } - -| TILDE expression - { doUnop BNot $2 } - -| argu expression %prec ARG_u - { ((fun args -> - let e = (fst $2) args in - UnOp((fst $1) args, e, typeOf e)), - - (fun e -> match e with - UnOp(uo, e', _) -> begin - match (snd $1) uo, (snd $2) e' with - Some m1, Some m2 -> Some (m1 @ m2) - | _ -> None - end - | _ -> None)) - } - - -| AND expression %prec ADDROF - { ((fun args -> - match (fst $2) args with - Lval l -> mkAddrOf l - | _ -> E.s (bug "AddrOf applied to a non lval")), - (fun e -> match e with - AddrOf l -> (snd $2) (Lval l) - | e -> (snd $2) (Lval (mkMem e NoOffset)))) - } - -| LPAREN expression RPAREN - { $2 } - -| expression PLUS expression - { ((fun args -> buildPlus ((fst $1) args) - ((fst $3) args)), - (fun e -> match e with - BinOp((PlusPI|PlusA), e1, e2, _) -> begin - match (snd $1) e1, (snd $3) e2 with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } - -| expression MINUS expression - { ((fun args -> buildMinus ((fst $1) args) - ((fst $3) args)), - - (fun e -> match e with - BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) -> - begin - match (snd $1) e1, (snd $3) e2 with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -| expression argb expression %prec ARG_b - { ((fun args -> - let e1 = (fst $1) args in - let bop = (fst $2) args in - let e2 = (fst $3) args in - let t1 = typeOf e1 in - BinOp(bop, e1, e2, t1)), - - (fun e -> match e with - BinOp(bop, e1, e2, _) -> begin - match (snd $1) e1,(snd $2) bop,(snd $3) e2 with - Some m1, Some m2, Some m3 -> - Some (m1 @ m2 @ m3) - | _, _, _ -> None - end - | _ -> None)) - } - -| expression STAR expression - { doBinop Mult $1 $3 } -| expression SLASH expression - { doBinop Div $1 $3 } -| expression PERCENT expression - { doBinop Mod $1 $3 } -| expression INF_INF expression - { doBinop Shiftlt $1 $3 } -| expression SUP_SUP expression - { doBinop Shiftrt $1 $3 } -| expression AND expression - { doBinop BAnd $1 $3 } -| expression PIPE expression - { doBinop BOr $1 $3 } -| expression CIRC expression - { doBinop BXor $1 $3 } -| expression EQ_EQ expression - { doBinop Eq $1 $3 } -| expression EXCLAM_EQ expression - { doBinop Ne $1 $3 } -| expression INF expression - { doBinop Lt $1 $3 } -| expression SUP expression - { doBinop Gt $1 $3 } -| expression INF_EQ expression - { doBinop Le $1 $3 } -| expression SUP_EQ expression - { doBinop Ge $1 $3 } - -| LPAREN typename RPAREN expression - { ((fun args -> - let t = (fst $2) args in - let e = (fst $4) args in - mkCast e t), - - (fun e -> - let t', e' = - match e with - CastE (t', e') -> t', e' - | _ -> typeOf e, e - in - match (snd $2) t', (snd $4 e') with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None)) - } -; - -/*(* Separate the ARG_ to ensure that the counting of arguments is right *)*/ -argu : -| ARG_u { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fu uo -> uo - | a -> wrongArgType currentArg "unnop" a), - - fun uo -> Some [ Fu uo ]) - } -; - -argb : -| ARG_b { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fb bo -> bo - | a -> wrongArgType currentArg "binop" a), - - fun bo -> Some [ Fb bo ]) - } -; - -constant: -| ARG_d { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fd n -> integer n - | a -> wrongArgType currentArg "integer" a), - - fun e -> match e with - Const(CInt64(n, _, _)) -> - Some [ Fd (Int64.to_int n) ] - | _ -> None) - } - -| ARG_g { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fg s -> Const(CStr s) - | a -> wrongArgType currentArg "string" a), - - fun e -> match e with - Const(CStr s) -> - Some [ Fg s ] - | _ -> None) - } -| CST_INT { let n = parseInt $1 in - ((fun args -> n), - - (fun e -> match e, n with - Const(CInt64(e', _, _)), - Const(CInt64(n', _, _)) when e' = n' -> Some [] - | _ -> None)) - } -; - - -/*(***************** LVALUES *******************)*/ -lval: -| ARG_l { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fl l -> l - | Fv v -> Var v, NoOffset - | a -> wrongArgType currentArg "lval" a), - - fun l -> Some [ Fl l ]) - } - -| argv offset %prec ARG_v - { ((fun args -> - let v = (fst $1) args in - (Var v, (fst $2) v.vtype args)), - - (fun l -> match l with - Var vi, off -> begin - match (snd $1) vi, (snd $2) off with - Some m1, Some m2 -> Some (m1 @ m2) - | _ -> None - end - | _ -> None)) - } - -| STAR expression { ((fun args -> mkMem ((fst $2) args) NoOffset), - - (fun l -> match l with - Mem e, NoOffset -> (snd $2) e - | _, _ -> None)) - } - -| expression ARROW IDENT offset - { ((fun args -> - let e = (fst $1) args in - let baset = - match unrollTypeDeep (typeOf e) with - TPtr (t, _) -> t - | _ -> E.s (bug "Expecting a pointer for field %s\n" $3) - in - let fi = getField baset $3 in - mkMem e (Field(fi, (fst $4) fi.ftype args))), - - (fun l -> match l with - Mem e, Field(fi, off) when fi.fname = $3 -> begin - match (snd $1) e, (snd $4) off with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _, _ -> None)) - } - -| LPAREN STAR expression RPAREN offset - { ((fun args -> - let e = (fst $3) args in - let baset = - match unrollTypeDeep (typeOf e) with - TPtr (t, _) -> t - | _ -> E.s (bug "Expecting a pointer\n") - in - mkMem e ((fst $5) baset args)), - - (fun l -> match l with - Mem e, off -> begin - match (snd $3) e, (snd $5 off) with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _, _ -> None)) - } - ; - -argv : -| ARG_v { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fv v -> v - | a -> wrongArgType currentArg "varinfo" a), - - fun v -> Some [ Fv v ]) - } -| IDENT { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fv v -> v - | a -> wrongArgType currentArg "varinfo" a), - (fun v -> - E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg))) - } -; - - -/*(********** OFFSETS *************)*/ -offset: -| ARG_o { let currentArg = $1 in - ((fun t args -> - match getArg currentArg args with - Fo o -> o - | a -> wrongArgType currentArg "offset" a), - - (fun off -> Some [ Fo off ])) - } - -| /* empty */ { ((fun t args -> NoOffset), - - (fun off -> match off with - NoOffset -> Some [] - | _ -> None)) - } - -| DOT IDENT offset { ((fun t args -> - let fi = getField t $2 in - Field (fi, (fst $3) fi.ftype args)), - - (fun off -> match off with - Field (fi, off') when fi.fname = $2 -> - (snd $3) off' - | _ -> None)) - } - -| LBRACKET expression RBRACKET offset - { ((fun t args -> - let bt = - match unrollType t with - TArray(bt, _, _) -> bt - | _ -> E.s (error "Formatcil: expecting an array for index") - in - let e = (fst $2) args in - Index(e, (fst $4) bt args)), - - (fun off -> match off with - Index (e, off') -> begin - match (snd $2) e, (snd $4) off with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -; - - -/*(************ TYPES **************)*/ -typename: one_formal { ((fun args -> - let (_, ft, _) = (fst $1) args in - ft), - - (fun t -> (snd $1) ("", t, []))) - } -; - -one_formal: -/*(* Do not allow attributes for the name *)*/ -| type_spec attributes decl - { ((fun args -> - let tal = (fst $2) args in - let ts = (fst $1) tal args in - let (fn, ft, _) = (fst $3) ts args in - (fn, ft, [])), - - (fun (fn, ft, fa) -> - match (snd $3) (fn, ft) with - Some (restt, m3) -> begin - match (snd $1) restt, - (snd $2) (typeAttrs restt)with - Some m1, Some m2 -> - Some (m1 @ m2 @ m3) - | _, _ -> None - end - | _ -> None)) - } - -| ARG_f - { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Ff (fn, ft, fa) -> (fn, ft, fa) - | a -> wrongArgType currentArg "formal" a), - - (fun (fn, ft, fa) -> Some [ Ff (fn, ft, fa) ])) - } -; - -type_spec: -| ARG_t { let currentArg = $1 in - ((fun al args -> - match getArg currentArg args with - Ft t -> typeAddAttributes al t - | a -> wrongArgType currentArg "type" a), - - (fun t -> Some [ Ft t ])) - } - -| VOID { ((fun al args -> TVoid al), - - (fun t -> match unrollType t with - TVoid _ -> Some [] - | _ -> None)) } - -| ARG_k { let currentArg = $1 in - ((fun al args -> - match getArg currentArg args with - Fk ik -> TInt(ik, al) - | a -> wrongArgType currentArg "ikind" a), - - (fun t -> match unrollType t with - TInt(ik, _) -> Some [ Fk ik ] - | _ -> None)) - } - -| CHAR { ((fun al args -> TInt(IChar, al)), - (matchIntType IChar)) } -| UNSIGNED CHAR { ((fun al args -> TInt(IUChar, al)), - matchIntType IUChar) } - -| SHORT { ((fun al args -> TInt(IShort, al)), - matchIntType IShort) } -| UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)), - matchIntType IUShort) } - -| INT { ((fun al args -> TInt(IInt, al)), - matchIntType IInt) } -| UNSIGNED INT { ((fun al args -> TInt(IUInt, al)), matchIntType IUInt) } - -| LONG { ((fun al args -> TInt(ILong, al)), - matchIntType ILong) } -| UNSIGNED LONG { ((fun al args -> TInt(IULong, al)), - matchIntType IULong) } - -| LONG LONG { ((fun al args -> TInt(ILongLong, al)), - - matchIntType ILongLong) - } -| UNSIGNED LONG LONG { ((fun al args -> TInt(IULongLong, al)), - - matchIntType IULongLong) - } - -| FLOAT { ((fun al args -> TFloat(FFloat, al)), - matchFloatType FFloat) - } -| DOUBLE { ((fun al args -> TFloat(FDouble, al)), - matchFloatType FDouble) } - -| STRUCT ARG_c { let currentArg = $2 in - ((fun al args -> - match getArg currentArg args with - Fc ci -> TComp(ci, al) - | a -> wrongArgType currentArg "compinfo" a), - - (fun t -> match unrollType t with - TComp(ci, _) -> Some [ Fc ci ] - | _ -> None)) - } -| UNION ARG_c { let currentArg = $2 in - ((fun al args -> - match getArg currentArg args with - Fc ci -> TComp(ci, al) - | a -> wrongArgType currentArg "compinfo" a), - - (fun t -> match unrollType t with - TComp(ci, _) -> Some [ Fc ci ] - | _ -> None)) - - } - -| TYPEOF LPAREN expression RPAREN - { ((fun al args -> typeAddAttributes al - (typeOf ((fst $3) args))), - - (fun t -> E.s (bug "Cannot match typeof(e)\n"))) - } -; - -decl: -| STAR attributes decl - { ((fun ts args -> - let al = (fst $2) args in - (fst $3) (TPtr(ts, al)) args), - - (fun (fn, ft) -> - match (snd $3) (fn, ft) with - Some (TPtr(bt, al), m2) -> begin - match (snd $2) al with - Some m1 -> Some (bt, m1 @ m2) - | _ -> None - end - | _ -> None)) - } - -| direct_decl { $1 } -; - -direct_decl: -| /* empty */ { ((fun ts args -> ("", ts, [])), - - (* Match any name in this case *) - (fun (fn, ft) -> - Some (unrollType ft, []))) - } - -| IDENT { ((fun ts args -> ($1, ts, [])), - - (fun (fn, ft) -> - if fn = "" || fn = $1 then - Some (unrollType ft, []) - else - None)) - } - -| LPAREN attributes decl RPAREN - { ((fun ts args -> - let al = (fst $2) args in - (fst $3) (typeAddAttributes al ts) args), - - (fun (fn, ft) -> begin - match (snd $3) (fn, ft) with - Some (restt, m2) -> begin - match (snd $2) (typeAttrs restt) with - Some m1 -> Some (restt, m1 @ m2) - | _ -> None - end - | _ -> None - end)) - } - -| direct_decl LBRACKET exp_opt RBRACKET - { ((fun ts args -> - (fst $1) (TArray(ts, (fst $3) args, [])) args), - - (fun (fn, ft) -> - match (snd $1) (fn, ft) with - Some (TArray(bt, lo, _), m1) -> begin - match (snd $3) lo with - Some m2 -> Some (unrollType bt, m1 @ m2) - | _ -> None - end - | _ -> None)) - } - - -/*(* We use parentheses around the function to avoid conflicts *)*/ -| LPAREN attributes decl RPAREN LPAREN parameters RPAREN - { ((fun ts args -> - let al = (fst $2) args in - let pars, isva = (fst $6) args in - (fst $3) (TFun(ts, pars, isva, al)) args), - - (fun (fn, ft) -> - match (snd $3) (fn, ft) with - Some (TFun(rt, args, isva, al), m1) -> begin - match (snd $2) al, (snd $6) (args, isva) with - Some m2, Some m6 - -> Some (unrollType rt, m1 @ m2 @ m6) - | _ -> None - end - | _ -> None)) - } -; - -parameters: -| /* empty */ { ((fun args -> (None, false)), - - (* Match any formals *) - (fun (pars, isva) -> - match pars, isva with - (_, false) -> Some [] - | _ -> None)) - } - -| parameters_ne { ((fun args -> - let (pars : (string * typ * attributes) list), - (isva : bool) = (fst $1) args in - (Some pars), isva), - - (function - ((Some pars), isva) -> (snd $1) (pars, isva) - | _ -> None)) - } -; -parameters_ne: -| ELLIPSIS - { ((fun args -> ([], true)), - - (function - ([], true) -> Some [] - | _ -> None)) - } - -| ARG_va { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fva isva -> ([], isva) - | a -> wrongArgType currentArg "vararg" a), - - (function - ([], isva) -> Some [ Fva isva ] - | _ -> None)) - } - -| ARG_F { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FF fl -> ( fl, false) - | a -> wrongArgType currentArg "formals" a), - - (function - (pars, false) -> Some [ FF pars ] - | _ -> None)) - } - -| one_formal { ((fun args -> ([(fst $1) args], false)), - - (function - ([ f ], false) -> (snd $1) f - | _ -> None)) - } - - -| one_formal COMMA parameters_ne - { ((fun args -> - let this = (fst $1) args in - let (rest, isva) = (fst $3) args in - (this :: rest, isva)), - - (function - ((f::rest, isva)) -> begin - match (snd $1) f, (snd $3) (rest, isva) with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -; - - - - - -exp_opt: - /* empty */ { ((fun args -> None), - (* Match anything if the pattern does not have a len *) - (fun _ -> Some [])) } - -| expression { ((fun args -> Some ((fst $1) args)), - - (fun lo -> match lo with - Some e -> (snd $1) e - | _ -> None)) - } -| ARG_eo { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Feo lo -> lo - | a -> wrongArgType currentArg "exp_opt" a), - - fun lo -> Some [ Feo lo ]) - } -; - - - -attributes: - /*(* Ignore other attributes *)*/ - /* empty */ { ((fun args -> []), - (fun attrs -> Some [])) } - -| ARG_A { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FA al -> al - | a -> wrongArgType currentArg "attributes" a), - - (fun al -> Some [ FA al ])) - } - -| attribute attributes - { ((fun args -> - addAttribute ((fst $1) args) ((fst $2) args)), - (* Pass all the attributes down *) - (fun attrs -> - match (snd $1) attrs, (snd $2) attrs with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None)) - } -; - -attribute: -| CONST { doAttr "const" None } -| RESTRICT { doAttr "restrict" None } -| VOLATILE { doAttr "volatile" None } -| ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN - { $4 } - -; - - -attr: -| IDENT - { doAttr $1 None } - -| IDENT LPAREN attr_args_ne RPAREN - { doAttr $1 (Some $3) } -; - -attr_args_ne: - attr_arg { ((fun args -> [ (fst $1) args ]), - - (fun aargs -> match aargs with - [ arg ] -> (snd $1) arg - | _ -> None)) - } -| attr_arg COMMA attr_args_ne { ((fun args -> - let this = (fst $1) args in - this :: ((fst $3) args)), - - (fun aargs -> match aargs with - h :: rest -> begin - match (snd $1) h, (snd $3) rest with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -| ARG_P { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FP al -> al - | a -> wrongArgType currentArg "attrparams" a), - - (fun al -> Some [ FP al ])) - } -; - -attr_arg: -| IDENT { ((fun args -> ACons($1, [])), - - (fun aarg -> match aarg with - ACons(id, []) when id = $1 -> Some [] - | _ -> None)) - } -| IDENT LPAREN attr_args_ne RPAREN - { ((fun args -> ACons($1, (fst $3) args)), - - (fun aarg -> match aarg with - ACons(id, args) when id = $1 -> - (snd $3) args - | _ -> None)) - } -| ARG_p { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - Fp p -> p - | a -> wrongArgType currentArg "attrparam" a), - - (fun ap -> Some [ Fp ap])) - } - -; - -/* (********** INSTRUCTIONS ***********) */ -instr: -| ARG_i SEMICOLON - { let currentArg = $1 in - ((fun loc args -> - match getArg currentArg args with - Fi i -> i - | a -> wrongArgType currentArg "instr" a), - - (fun i -> Some [ Fi i])) - } - -| lval EQ expression SEMICOLON - { ((fun loc args -> - Set((fst $1) args, (fst $3) args, loc)), - - (fun i -> match i with - Set (lv, e, l) -> begin - match (snd $1) lv, (snd $3) e with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } - -| lval PLUS_EQ expression SEMICOLON - { ((fun loc args -> - let l = (fst $1) args in - Set(l, buildPlus (Lval l) ((fst $3) args), loc)), - - matchBinopEq - (fun bop -> bop = PlusPI || bop = PlusA) - (snd $1) (snd $3)) - } - -| lval MINUS_EQ expression SEMICOLON - { ((fun loc args -> - let l = (fst $1) args in - Set(l, - buildMinus (Lval l) ((fst $3) args), loc)), - - matchBinopEq (fun bop -> bop = MinusA - || bop = MinusPP - || bop = MinusPI) - (snd $1) (snd $3)) - } -| lval STAR_EQ expression SEMICOLON - { doBinopEq Mult $1 $3 } - -| lval SLASH_EQ expression SEMICOLON - { doBinopEq Div $1 $3 } - -| lval PERCENT_EQ expression SEMICOLON - { doBinopEq Mod $1 $3 } - -| lval AND_EQ expression SEMICOLON - { doBinopEq BAnd $1 $3 } - -| lval PIPE_EQ expression SEMICOLON - { doBinopEq BOr $1 $3 } - -| lval CIRC_EQ expression SEMICOLON - { doBinopEq BXor $1 $3 } - -| lval INF_INF_EQ expression SEMICOLON - { doBinopEq Shiftlt $1 $3 } - -| lval SUP_SUP_EQ expression SEMICOLON - { doBinopEq Shiftrt $1 $3 } - -/* (* Would be nice to be able to condense the next three rules but we get - * into conflicts *)*/ -| lval EQ lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call(Some ((fst $1) args), Lval ((fst $3) args), - (fst $5) args, loc)), - - (fun i -> match i with - Call(Some l, Lval f, args, loc) -> begin - match (snd $1) l, (snd $3) f, (snd $5) args with - Some m1, Some m2, Some m3 -> - Some (m1 @ m2 @ m3) - | _, _, _ -> None - end - | _ -> None)) - } - -| lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call(None, Lval ((fst $1) args), - (fst $3) args, loc)), - - (fun i -> match i with - Call(None, Lval f, args, loc) -> begin - match (snd $1) f, (snd $3) args with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } - -| arglo lval LPAREN arguments RPAREN SEMICOLON - { ((fun loc args -> - Call((fst $1) args, Lval ((fst $2) args), - (fst $4) args, loc)), - - (fun i -> match i with - Call(lo, Lval f, args, loc) -> begin - match (snd $1) lo, (snd $2) f, (snd $4) args with - Some m1, Some m2, Some m3 -> - Some (m1 @ m2 @ m3) - | _, _, _ -> None - end - | _ -> None)) - } -; - -/* (* Separate this out to ensure that the counting or arguments is right *)*/ -arglo: - ARG_lo { let currentArg = $1 in - ((fun args -> - let res = - match getArg currentArg args with - Flo x -> x - | a -> wrongArgType currentArg "lval option" a - in - res), - - (fun lo -> Some [ Flo lo ])) - } -; -arguments: - /* empty */ { ((fun args -> []), - - (fun actuals -> match actuals with - [] -> Some [] - | _ -> None)) - } - -| arguments_ne { $1 } -; - -arguments_ne: - expression { ((fun args -> [ (fst $1) args ]), - - (fun actuals -> match actuals with - [ h ] -> (snd $1) h - | _ -> None)) - } - -| ARG_E { let currentArg = $1 in - ((fun args -> - match getArg currentArg args with - FE el -> el - | a -> wrongArgType currentArg "arguments" a), - - (fun actuals -> Some [ FE actuals ])) - } - -| expression COMMA arguments_ne - { ((fun args -> ((fst $1) args) :: ((fst $3) args)), - - (fun actuals -> match actuals with - h :: rest -> begin - match (snd $1) h, (snd $3) rest with - Some m1, Some m2 -> Some (m1 @ m2) - | _, _ -> None - end - | _ -> None)) - } -; - - -/*(******** STATEMENTS *********)*/ -stmt: - IF LPAREN expression RPAREN stmt %prec IF - { (fun mkTemp loc args -> - mkStmt (If((fst $3) args, - mkBlock [ $5 mkTemp loc args ], - mkBlock [], loc))) - } -| IF LPAREN expression RPAREN stmt ELSE stmt - { (fun mkTemp loc args -> - mkStmt (If((fst $3) args, - mkBlock [ $5 mkTemp loc args ], - mkBlock [ $7 mkTemp loc args], loc))) - } -| RETURN exp_opt SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Return((fst $2) args, loc))) - } -| BREAK SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Break loc)) - } -| CONTINUE SEMICOLON - { (fun mkTemp loc args -> - mkStmt (Continue loc)) - } -| LBRACE stmt_list RBRACE - { (fun mkTemp loc args -> - let stmts = $2 mkTemp loc args in - mkStmt (Block (mkBlock (stmts)))) - } -| WHILE LPAREN expression RPAREN stmt - { (fun mkTemp loc args -> - let e = (fst $3) args in - let e = - if isPointerType(typeOf e) then - mkCast e !upointType - else e - in -(* - mkStmt - (Loop (mkBlock [ mkStmt - (If(e, - mkBlock [], - mkBlock [ mkStmt - (Break loc) ], - loc)); - $5 mkTemp loc args ], - loc, None, None)) -*) - mkStmt - (While (e, mkBlock [ $5 mkTemp loc args ], loc))) - } -| instr_list { (fun mkTemp loc args -> - mkStmt (Instr ($1 loc args))) - } -| ARG_s { let currentArg = $1 in - (fun mkTemp loc args -> - match getArg currentArg args with - Fs s -> s - | a -> wrongArgType currentArg "stmt" a) } -; - -stmt_list: - /* empty */ { (fun mkTemp loc args -> []) } - -| ARG_S { let currentArg = $1 in - (fun mkTemp loc args -> - match getArg currentArg args with - | FS sl -> sl - | a -> wrongArgType currentArg "stmts" a) - } -| stmt stmt_list - { (fun mkTemp loc args -> - let this = $1 mkTemp loc args in - this :: ($2 mkTemp loc args)) - } -/* (* We can also have a declaration *) */ -| type_spec attributes decl maybe_init SEMICOLON stmt_list - { (fun mkTemp loc args -> - let tal = (fst $2) args in - let ts = (fst $1) tal args in - let (n, t, _) = (fst $3) ts args in - let init = $4 args in - (* Before we proceed we must create the variable *) - let v = mkTemp n t in - (* Now we parse the rest *) - let rest = $6 mkTemp loc ((n, Fv v) :: args) in - (* Now we add the initialization instruction to the - * front *) - match init with - NoInit -> rest - | InitExp e -> - mkStmtOneInstr (Set((Var v, NoOffset), e, loc)) - :: rest - | InitCall (f, args) -> - mkStmtOneInstr (Call(Some (Var v, NoOffset), - Lval f, args, loc)) - :: rest - - ) - } -; - -instr_list: - /*(* Set this rule to very low precedence to ensure that we shift as - many instructions as possible *)*/ - instr %prec COMMA - { (fun loc args -> [ ((fst $1) loc args) ]) } -| ARG_I { let currentArg = $1 in - (fun loc args -> - match getArg currentArg args with - | FI il -> il - | a -> wrongArgType currentArg "instrs" a) - } -| instr instr_list - { (fun loc args -> - let this = (fst $1) loc args in - this :: ($2 loc args)) - } -; - - -maybe_init: -| { (fun args -> NoInit) } -| EQ expression { (fun args -> InitExp ((fst $2) args)) } -| EQ lval LPAREN arguments RPAREN - { (fun args -> - InitCall((fst $2) args, (fst $4) args)) } -; -%% - - - - - - - diff --git a/cil/src/frontc/cabs.ml b/cil/src/frontc/cabs.ml deleted file mode 100644 index 78ac02f..0000000 --- a/cil/src/frontc/cabs.ml +++ /dev/null @@ -1,396 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** This file was originally part of Hugues Casee's frontc 2.0, and has been - * extensively changed since. -** -** 1.0 3.22.99 Hugues Cassé First version. -** 2.0 George Necula 12/12/00: Many extensions - **) - -(* -** Types -*) - -type cabsloc = { - lineno : int; - filename: string; - byteno: int; -} - -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10;} - -(* clexer puts comments here *) -let commentsGA = GrowArray.make 100 (GrowArray.Elem(cabslu,"",false)) - -type typeSpecifier = (* Merge all specifiers into one type *) - Tvoid (* Type specifier ISO 6.7.2 *) - | Tchar - | Tshort - | Tint - | Tlong - | Tint64 - | Tfloat - | Tdouble - | Tsigned - | Tunsigned - | Tnamed of string - (* each of the following three kinds of specifiers contains a field - * or item list iff it corresponds to a definition (as opposed to - * a forward declaration or simple reference to the type); they - * also have a list of __attribute__s that appeared between the - * keyword and the type name (definitions only) *) - | Tstruct of string * field_group list option * attribute list - | Tunion of string * field_group list option * attribute list - | Tenum of string * enum_item list option * attribute list - | TtypeofE of expression (* GCC __typeof__ *) - | TtypeofT of specifier * decl_type (* GCC __typeof__ *) - -and storage = - NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER - -and funspec = - INLINE | VIRTUAL | EXPLICIT - -and cvspec = - CV_CONST | CV_VOLATILE | CV_RESTRICT - -(* Type specifier elements. These appear at the start of a declaration *) -(* Everywhere they appear in this file, they appear as a 'spec_elem list', *) -(* which is not interpreted by cabs -- rather, this "word soup" is passed *) -(* on to the compiler. Thus, we can represent e.g. 'int long float x' even *) -(* though the compiler will of course choke. *) -and spec_elem = - SpecTypedef - | SpecCV of cvspec (* const/volatile *) - | SpecAttr of attribute (* __attribute__ *) - | SpecStorage of storage - | SpecInline - | SpecType of typeSpecifier - | SpecPattern of string (* specifier pattern variable *) - -(* decided to go ahead and replace 'spec_elem list' with specifier *) -and specifier = spec_elem list - - -(* Declarator type. They modify the base type given in the specifier. Keep - * them in the order as they are printed (this means that the top level - * constructor for ARRAY and PTR is the inner-level in the meaning of the - * declared type) *) -and decl_type = - | JUSTBASE (* Prints the declared name *) - | PARENTYPE of attribute list * decl_type * attribute list - (* Prints "(attrs1 decl attrs2)". - * attrs2 are attributes of the - * declared identifier and it is as - * if they appeared at the very end - * of the declarator. attrs1 can - * contain attributes for the - * identifier or attributes for the - * enclosing type. *) - | ARRAY of decl_type * attribute list * expression - (* Prints "decl [ attrs exp ]". - * decl is never a PTR. *) - | PTR of attribute list * decl_type (* Prints "* attrs decl" *) - | PROTO of decl_type * single_name list * bool - (* Prints "decl (args[, ...])". - * decl is never a PTR.*) - -(* The base type and the storage are common to all names. Each name might - * contain type or storage modifiers *) -(* e.g.: int x, y; *) -and name_group = specifier * name list - -(* The optional expression is the bitfield *) -and field_group = specifier * (name * expression option) list - -(* like name_group, except the declared variables are allowed to have initializers *) -(* e.g.: int x=1, y=2; *) -and init_name_group = specifier * init_name list - -(* The decl_type is in the order in which they are printed. Only the name of - * the declared identifier is pulled out. The attributes are those that are - * printed after the declarator *) -(* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *) -(* the string, and decl_type will be PTR([], JUSTBASE) *) -and name = string * decl_type * attribute list * cabsloc - -(* A variable declarator ("name") with an initializer *) -and init_name = name * init_expression - -(* Single names are for declarations that cannot come in groups, like - * function parameters and functions *) -and single_name = specifier * name - - -and enum_item = string * expression * cabsloc - -(* -** Declaration definition (at toplevel) -*) -and definition = - FUNDEF of single_name * block * cabsloc * cabsloc - | DECDEF of init_name_group * cabsloc (* global variable(s), or function prototype *) - | TYPEDEF of name_group * cabsloc - | ONLYTYPEDEF of specifier * cabsloc - | GLOBASM of string * cabsloc - | PRAGMA of expression * cabsloc - | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *) - (* toplevel form transformer, from the first definition to the *) - (* second group of definitions *) - | TRANSFORMER of definition * definition list * cabsloc - (* expression transformer: source and destination *) - | EXPRTRANSFORMER of expression * expression * cabsloc - - -(* the string is a file name, and then the list of toplevel forms *) -and file = string * definition list - - -(* -** statements -*) - -(* A block contains a list of local label declarations ( GCC's ({ __label__ - * l1, l2; ... }) ) , a list of definitions and a list of statements *) -and block = - { blabels: string list; - battrs: attribute list; - bstmts: statement list - } - -(* GCC asm directives have lots of extra information to guide the optimizer *) -and asm_details = - { aoutputs: (string * expression) list; (* constraints and expressions for outputs *) - ainputs: (string * expression) list; (* constraints and expressions for inputs *) - aclobbers: string list (* clobbered registers *) - } - -and statement = - NOP of cabsloc - | COMPUTATION of expression * cabsloc - | BLOCK of block * cabsloc - | SEQUENCE of statement * statement * cabsloc - | IF of expression * statement * statement * cabsloc - | WHILE of expression * statement * cabsloc - | DOWHILE of expression * statement * cabsloc - | FOR of for_clause * expression * expression * statement * cabsloc - | BREAK of cabsloc - | CONTINUE of cabsloc - | RETURN of expression * cabsloc - | SWITCH of expression * statement * cabsloc - | CASE of expression * statement * cabsloc - | CASERANGE of expression * expression * statement * cabsloc - | DEFAULT of statement * cabsloc - | LABEL of string * statement * cabsloc - | GOTO of string * cabsloc - | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *) - | DEFINITION of definition (*definition or declaration of a variable or type*) - - | ASM of attribute list * (* typically only volatile and const *) - string list * (* template *) - asm_details option * (* extra details to guide GCC's optimizer *) - cabsloc - - (** MS SEH *) - | TRY_EXCEPT of block * expression * block * cabsloc - | TRY_FINALLY of block * block * cabsloc - -and for_clause = - FC_EXP of expression - | FC_DECL of definition - -(* -** Expressions -*) -and binary_operator = - ADD | SUB | MUL | DIV | MOD - | AND | OR - | BAND | BOR | XOR | SHL | SHR - | EQ | NE | LT | GT | LE | GE - | ASSIGN - | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN - | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN - -and unary_operator = - MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF - | PREINCR | PREDECR | POSINCR | POSDECR - -and expression = - NOTHING - | UNARY of unary_operator * expression - | LABELADDR of string (* GCC's && Label *) - | BINARY of binary_operator * expression * expression - | QUESTION of expression * expression * expression - - (* A CAST can actually be a constructor expression *) - | CAST of (specifier * decl_type) * init_expression - - (* There is a special form of CALL in which the function called is - __builtin_va_arg and the second argument is sizeof(T). This - should be printed as just T *) - | CALL of expression * expression list - | COMMA of expression list - | CONSTANT of constant - | VARIABLE of string - | EXPR_SIZEOF of expression - | TYPE_SIZEOF of specifier * decl_type - | EXPR_ALIGNOF of expression - | TYPE_ALIGNOF of specifier * decl_type - | INDEX of expression * expression - | MEMBEROF of expression * string - | MEMBEROFPTR of expression * string - | GNU_BODY of block - | EXPR_PATTERN of string (* pattern variable, and name *) - -and constant = - | CONST_INT of string (* the textual representation *) - | CONST_FLOAT of string (* the textual representaton *) - | CONST_CHAR of int64 list - | CONST_WCHAR of int64 list - | CONST_STRING of string - | CONST_WSTRING of int64 list - (* ww: wstrings are stored as an int64 list at this point because - * we might need to feed the wide characters piece-wise into an - * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that - * doesn't happen we will convert it to an (escaped) string before - * passing it to Cil. *) - -and init_expression = - | NO_INIT - | SINGLE_INIT of expression - | COMPOUND_INIT of (initwhat * init_expression) list - -and initwhat = - NEXT_INIT - | INFIELD_INIT of string * initwhat - | ATINDEX_INIT of expression * initwhat - | ATINDEXRANGE_INIT of expression * expression - - - (* Each attribute has a name and some - * optional arguments *) -and attribute = string * expression list - - -(*********** HELPER FUNCTIONS **********) - -let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu) - -let rec isStatic = function - [] -> false - | (SpecStorage STATIC) :: _ -> true - | _ :: rest -> isStatic rest - -let rec isExtern = function - [] -> false - | (SpecStorage EXTERN) :: _ -> true - | _ :: rest -> isExtern rest - -let rec isInline = function - [] -> false - | SpecInline :: _ -> true - | _ :: rest -> isInline rest - -let rec isTypedef = function - [] -> false - | SpecTypedef :: _ -> true - | _ :: rest -> isTypedef rest - - -let get_definitionloc (d : definition) : cabsloc = - match d with - | FUNDEF(_, _, l, _) -> l - | DECDEF(_, l) -> l - | TYPEDEF(_, l) -> l - | ONLYTYPEDEF(_, l) -> l - | GLOBASM(_, l) -> l - | PRAGMA(_, l) -> l - | TRANSFORMER(_, _, l) -> l - | EXPRTRANSFORMER(_, _, l) -> l - | LINKAGE (_, l, _) -> l - -let get_statementloc (s : statement) : cabsloc = -begin - match s with - | NOP(loc) -> loc - | COMPUTATION(_,loc) -> loc - | BLOCK(_,loc) -> loc - | SEQUENCE(_,_,loc) -> loc - | IF(_,_,_,loc) -> loc - | WHILE(_,_,loc) -> loc - | DOWHILE(_,_,loc) -> loc - | FOR(_,_,_,_,loc) -> loc - | BREAK(loc) -> loc - | CONTINUE(loc) -> loc - | RETURN(_,loc) -> loc - | SWITCH(_,_,loc) -> loc - | CASE(_,_,loc) -> loc - | CASERANGE(_,_,_,loc) -> loc - | DEFAULT(_,loc) -> loc - | LABEL(_,_,loc) -> loc - | GOTO(_,loc) -> loc - | COMPGOTO (_, loc) -> loc - | DEFINITION d -> get_definitionloc d - | ASM(_,_,_,loc) -> loc - | TRY_EXCEPT(_, _, _, loc) -> loc - | TRY_FINALLY(_, _, loc) -> loc -end - - -let explodeStringToInts (s: string) : int64 list = - let rec allChars i acc = - if i < 0 then acc - else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc) - in - allChars (-1 + String.length s) [] - -let valueOfDigit chr = - let int_value = - match chr with - '0'..'9' -> (Char.code chr) - (Char.code '0') - | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10 - | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10 - | _ -> Errormsg.s (Errormsg.bug "not a digit") in - Int64.of_int int_value - - -open Pretty -let d_cabsloc () cl = - text cl.filename ++ text ":" ++ num cl.lineno diff --git a/cil/src/frontc/cabs2cil.ml b/cil/src/frontc/cabs2cil.ml deleted file mode 100644 index 31b65b5..0000000 --- a/cil/src/frontc/cabs2cil.ml +++ /dev/null @@ -1,6238 +0,0 @@ -(* MODIF: allow E.Error to propagate *) - -(* MODIF: for pointer comparison, avoid systematic cast to unsigned int *) - -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -(* MODIF: Return statement no longer added when the body of the function - falls-through. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* Type check and elaborate ABS to CIL *) - -(* The references to ISO means ANSI/ISO 9899-1999 *) -module A = Cabs -module E = Errormsg -module H = Hashtbl -module IH = Inthash -module AL = Alpha - -open Cabs -open Pretty -open Cil -open Trace - - -let mydebugfunction () = - E.s (error "mydebugfunction") - -let debugGlobal = false - -(** NDC added command line parameter **) -(* Turn on tranformation that forces correct parameter evaluation order *) -let forceRLArgEval = ref false - -(* Leave a certain global alone. Use a negative number to disable. *) -let nocil: int ref = ref (-1) - -(* Indicates whether we're allowed to duplicate small chunks. *) -let allowDuplication: bool ref = ref true - -(* ---------- source error message handling ------------- *) -let lu = locUnknown -let cabslu = {lineno = -10; - filename = "cabs lu"; - byteno = -10;} - - -(** Interface to the Cprint printer *) -let withCprint (f: 'a -> unit) (x: 'a) : unit = - Cprint.commit (); Cprint.flush (); - let old = !Cprint.out in - Cprint.out := !E.logChannel; - f x; - Cprint.commit (); Cprint.flush (); - flush !Cprint.out; - Cprint.out := old - - -(** Keep a list of the variable ID for the variables that were created to - * hold the result of function calls *) -let callTempVars: unit IH.t = IH.create 13 - -(* Keep a list of functions that were called without a prototype. *) -let noProtoFunctions : bool IH.t = IH.create 13 - -(* Check that s starts with the prefix p *) -let prefix p s = - let lp = String.length p in - let ls = String.length s in - lp <= ls && String.sub s 0 lp = p - -(***** COMPUTED GOTO ************) - -(* The address of labels are small integers (starting from 0). A computed - * goto is replaced with a switch on the address of the label. We generate - * only one such switch and we'll jump to it from all computed gotos. To - * accomplish this we'll add a local variable to store the target of the - * goto. *) - -(* The local variable in which to put the detination of the goto and the - * statement where to jump *) -let gotoTargetData: (varinfo * stmt) option ref = ref None - -(* The "addresses" of labels *) -let gotoTargetHash: (string, int) H.t = H.create 13 -let gotoTargetNextAddr: int ref = ref 0 - - -(********** TRANSPARENT UNION ******) -(* Check if a type is a transparent union, and return the first field if it - * is *) -let isTransparentUnion (t: typ) : fieldinfo option = - match unrollType t with - TComp (comp, _) when not comp.cstruct -> - (* Turn transparent unions into the type of their first field *) - if hasAttribute "transparent_union" (typeAttrs t) then begin - match comp.cfields with - f :: _ -> Some f - | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp)) - end else - None - | _ -> None - -(* When we process an argument list, remember the argument index which has a - * transparent union type, along with the original type. We need this to - * process function definitions *) -let transparentUnionArgs : (int * typ) list ref = ref [] - -let debugLoc = false -let convLoc (l : cabsloc) = - if debugLoc then - ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno); - {line = l.lineno; file = l.filename; byte = l.byteno;} - - -let isOldStyleVarArgName n = - if !msvcMode then n = "va_alist" - else n = "__builtin_va_alist" - -let isOldStyleVarArgTypeName n = - if !msvcMode then n = "va_list" || n = "__ccured_va_list" - else n = "__builtin_va_alist_t" - -(* Weimer - * multi-character character constants - * In MSCV, this code works: - * - * long l1 = 'abcd'; // note single quotes - * char * s = "dcba"; - * long * lptr = ( long * )s; - * long l2 = *lptr; - * assert(l1 == l2); - * - * We need to change a multi-character character literal into the - * appropriate integer constant. However, the plot sickens: we - * must also be able to handle things like 'ab\nd' (value = * "d\nba") - * and 'abc' (vale = *"cba"). - * - * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we - * multiply and add to get the desired value. - *) - -(* Given a character constant (like 'a' or 'abc') as a list of 64-bit - * values, turn it into a CIL constant. Multi-character constants are - * treated as multi-digit numbers with radix given by the bit width of - * the specified type (either char or wchar_t). *) -let reduce_multichar typ : int64 list -> int64 = - let radix = bitsSizeOf typ in - List.fold_left - (fun acc -> Int64.add (Int64.shift_left acc radix)) - Int64.zero - -let interpret_character_constant char_list = - let value = reduce_multichar charType char_list in - if value < (Int64.of_int 256) then - (* ISO C 6.4.4.4.10: single-character constants have type int *) - (CChr(Char.chr (Int64.to_int value))), intType - else begin - let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in - if value <= (Int64.of_int32 Int32.max_int) then - (CInt64(value,IULong,orig_rep)),(TInt(IULong,[])) - else - (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[])) - end - -(*** EXPRESSIONS *************) - - (* We collect here the program *) -let theFile : global list ref = ref [] -let theFileTypes : global list ref = ref [] - -let initGlobals () = theFile := []; theFileTypes := [] - - -let cabsPushGlobal (g: global) = - pushGlobal g ~types:theFileTypes ~variables:theFile - -(* Keep track of some variable ids that must be turned into definitions. We - * do this when we encounter what appears a definition of a global but - * without initializer. We leave it a declaration because maybe down the road - * we see another definition with an initializer. But if we don't see any - * then we turn the last such declaration into a definition without - * initializer *) -let mustTurnIntoDef: bool IH.t = IH.create 117 - -(* Globals that have already been defined. Indexed by the variable name. *) -let alreadyDefined: (string, location) H.t = H.create 117 - -(* Globals that were created due to static local variables. We chose their - * names to be distinct from any global encountered at the time. But we might - * see a global with conflicting name later in the file. *) -let staticLocals: (string, varinfo) H.t = H.create 13 - - -(* Typedefs. We chose their names to be distinct from any global encounterd - * at the time. But we might see a global with conflicting name later in the - * file *) -let typedefs: (string, typeinfo) H.t = H.create 13 - -let popGlobals () = - let rec revonto (tail: global list) = function - [] -> tail - - | GVarDecl (vi, l) :: rest - when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid -> - IH.remove mustTurnIntoDef vi.vid; - revonto (GVar (vi, {init = None}, l) :: tail) rest - - | x :: rest -> revonto (x :: tail) rest - in - revonto (revonto [] !theFile) !theFileTypes - - -(********* ENVIRONMENTS ***************) - -(* The environment is kept in two distinct data structures. A hash table maps - * each original variable name into a varinfo (for variables, or an - * enumeration tag, or a type). (Note that the varinfo might contain an - * alpha-converted name different from that of the lookup name.) The Ocaml - * hash tables can keep multiple mappings for a single key. Each time the - * last mapping is returned and upon deletion the old mapping is restored. To - * keep track of local scopes we also maintain a list of scopes (represented - * as lists). *) -type envdata = - EnvVar of varinfo (* The name refers to a variable - * (which could also be a function) *) - | EnvEnum of exp * typ (* The name refers to an enumeration - * tag for which we know the value - * and the host type *) - | EnvTyp of typ (* The name is of the form "struct - * foo", or "union foo" or "enum foo" - * and refers to a type. Note that - * the name of the actual type might - * be different from foo due to alpha - * conversion *) - | EnvLabel of string (* The name refers to a label. This - * is useful for GCC's locally - * declared labels. The lookup name - * for this category is "label foo" *) - -let env : (string, envdata * location) H.t = H.create 307 -(* We also keep a global environment. This is always a subset of the env *) -let genv : (string, envdata * location) H.t = H.create 307 - - (* In the scope we keep the original name, so we can remove them from the - * hash table easily *) -type undoScope = - UndoRemoveFromEnv of string - | UndoResetAlphaCounter of location AL.alphaTableData ref * - location AL.alphaTableData - | UndoRemoveFromAlphaTable of string - -let scopes : undoScope list ref list ref = ref [] - -let isAtTopLevel () = - !scopes = [] - - -(* When you add to env, you also add it to the current scope *) -let addLocalToEnv (n: string) (d: envdata) = -(* ignore (E.log "%a: adding local %s to env\n" d_loc !currentLoc n); *) - H.add env n (d, !currentLoc); - (* If we are in a scope, then it means we are not at top level. Add the - * name to the scope *) - (match !scopes with - [] -> begin - match d with - EnvVar _ -> - E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n) - | _ -> () (* We might add types *) - end - | s :: _ -> - s := (UndoRemoveFromEnv n) :: !s) - - -let addGlobalToEnv (k: string) (d: envdata) : unit = -(* ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *) - H.add env k (d, !currentLoc); - (* Also add it to the global environment *) - H.add genv k (d, !currentLoc) - - - -(* Create a new name based on a given name. The new name is formed from a - * prefix (obtained from the given name as the longest prefix that ends with - * a non-digit), followed by a '_' and then by a positive integer suffix. The - * first argument is a table mapping name prefixes with the largest suffix - * used so far for that prefix. The largest suffix is one when only the - * version without suffix has been used. *) -let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307 - (* vars and enum tags. For composite types we have names like "struct - * foo" or "union bar" *) - -(* To keep different name scopes different, we add prefixes to names - * specifying the kind of name: the kind can be one of "" for variables or - * enum tags, "struct" for structures and unions (they share the name space), - * "enum" for enumerations, or "type" for types *) -let kindPlusName (kind: string) - (origname: string) : string = - if kind = "" then origname else - kind ^ " " ^ origname - - -let stripKind (kind: string) (kindplusname: string) : string = - let l = 1 + String.length kind in - if l > 1 then - String.sub kindplusname l (String.length kindplusname - l) - else - kindplusname - -let newAlphaName (globalscope: bool) (* The name should have global scope *) - (kind: string) - (origname: string) : string * location = - let lookupname = kindPlusName kind origname in - (* If we are in a scope then it means that we are alpha-converting a local - * name. Go and add stuff to reset the state of the alpha table but only to - * the top-most scope (that of the enclosing function) *) - let rec findEnclosingFun = function - [] -> (* At global scope *)() - | [s] -> begin - let prefix = AL.getAlphaPrefix lookupname in - try - let countref = H.find alphaTable prefix in - s := (UndoResetAlphaCounter (countref, !countref)) :: !s - with Not_found -> - s := (UndoRemoveFromAlphaTable prefix) :: !s - end - | _ :: rest -> findEnclosingFun rest - in - if not globalscope then - findEnclosingFun !scopes; - let newname, oldloc = - AL.newAlphaName alphaTable None lookupname !currentLoc in - stripKind kind newname, oldloc - - - - -let explodeString (nullterm: bool) (s: string) : char list = - let rec allChars i acc = - if i < 0 then acc - else allChars (i - 1) ((String.get s i) :: acc) - in - allChars (-1 + String.length s) - (if nullterm then [Char.chr 0] else []) - -(*** In order to process GNU_BODY expressions we must record that a given - *** COMPUTATION is interesting *) -let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref - = ref (A.NOP cabslu, ref None) - -(*** When we do statements we need to know the current return type *) -let currentReturnType : typ ref = ref (TVoid([])) -let currentFunctionFDEC: fundec ref = ref dummyFunDec - - -let lastStructId = ref 0 -let anonStructName (k: string) (suggested: string) = - incr lastStructId; - "__anon" ^ k ^ (if suggested <> "" then "_" ^ suggested else "") - ^ "_" ^ (string_of_int (!lastStructId)) - - -let constrExprId = ref 0 - - -let startFile () = - H.clear env; - H.clear genv; - H.clear alphaTable; - lastStructId := 0 - - - -let enterScope () = - scopes := (ref []) :: !scopes - - (* Exit a scope and clean the environment. We do not yet delete from - * the name table *) -let exitScope () = - let this, rest = - match !scopes with - car :: cdr -> car, cdr - | [] -> E.s (error "Not in a scope") - in - scopes := rest; - let rec loop = function - [] -> () - | UndoRemoveFromEnv n :: t -> - H.remove env n; loop t - | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t - | UndoResetAlphaCounter (vref, oldv) :: t -> - vref := oldv; - loop t - in - loop !this - -(* Lookup a variable name. Return also the location of the definition. Might - * raise Not_found *) -let lookupVar (n: string) : varinfo * location = - match H.find env n with - (EnvVar vi), loc -> vi, loc - | _ -> raise Not_found - -let lookupGlobalVar (n: string) : varinfo * location = - match H.find genv n with - (EnvVar vi), loc -> vi, loc - | _ -> raise Not_found - -let docEnv () = - let acc : (string * (envdata * location)) list ref = ref [] in - let doone () = function - EnvVar vi, l -> - dprintf "Var(%s,global=%b) (at %a)" vi.vname vi.vglob d_loc l - | EnvEnum (tag, typ), l -> dprintf "Enum (at %a)" d_loc l - | EnvTyp t, l -> text "typ" - | EnvLabel l, _ -> text ("label " ^ l) - in - H.iter (fun k d -> acc := (k, d) :: !acc) env; - docList ~sep:line (fun (k, d) -> dprintf " %s -> %a" k doone d) () !acc - - - -(* Add a new variable. Do alpha-conversion if necessary *) -let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = -(* - ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname); -*) - (* Announce the name to the alpha conversion table *) - let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in - (* Make a copy of the vi if the name has changed. Never change the name for - * global variables *) - let newvi = - if vi.vname = newname then - vi - else begin - if vi.vglob then begin - (* Perhaps this is because we have seen a static local which happened - * to get the name that we later want to use for a global. *) - try - let static_local_vi = H.find staticLocals vi.vname in - H.remove staticLocals vi.vname; - (* Use the new name for the static local *) - static_local_vi.vname <- newname; - (* And continue using the last one *) - vi - with Not_found -> begin - (* Or perhaps we have seen a typedef which stole our name. This is - possible because typedefs use the same name space *) - try - let typedef_ti = H.find typedefs vi.vname in - H.remove typedefs vi.vname; - (* Use the new name for the typedef instead *) - typedef_ti.tname <- newname; - (* And continue using the last name *) - vi - with Not_found -> - E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a" - vi.vname newname d_loc oldloc); - end - end else begin - (* We have changed the name of a local variable. Can we try to detect - * if the other variable was also local in the same scope? Not for - * now. *) - copyVarinfo vi newname - end - end - in - (* Store all locals in the slocals (in reversed order). We'll reverse them - * and take out the formals at the end of the function *) - if not vi.vglob then - !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals; - - (if addtoenv then - if vi.vglob then - addGlobalToEnv vi.vname (EnvVar newvi) - else - addLocalToEnv vi.vname (EnvVar newvi)); -(* - ignore (E.log " new=%s\n" newvi.vname); -*) -(* ignore (E.log "After adding %s alpha table is: %a\n" - newvi.vname docAlphaTable alphaTable); *) - newvi - - -(* Strip the "const" from the type. It is unfortunate that const variables - * can only be set in initialization. Once we decided to move all - * declarations to the top of the functions, we have no way of setting a - * "const" variable. Furthermore, if the type of the variable is an array or - * a struct we must recursively strip the "const" from fields and array - * elements. *) -let rec stripConstLocalType (t: typ) : typ = - let dc a = - if hasAttribute "const" a then - dropAttribute "const" a - else a - in - match t with - | TPtr (bt, a) -> - (* We want to be able to detect by pointer equality if the type has - * changed. So, don't realloc the type unless necessary. *) - let a' = dc a in if a != a' then TPtr(bt, a') else t - | TInt (ik, a) -> - let a' = dc a in if a != a' then TInt(ik, a') else t - | TFloat(fk, a) -> - let a' = dc a in if a != a' then TFloat(fk, a') else t - | TNamed (ti, a) -> - (* We must go and drop the consts from the typeinfo as well ! *) - let t' = stripConstLocalType ti.ttype in - if t != t' then begin - (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *) - ti.ttype <- t' - end; - let a' = dc a in if a != a' then TNamed(ti, a') else t - - | TEnum (ei, a) -> - let a' = dc a in if a != a' then TEnum(ei, a') else t - - | TArray(bt, leno, a) -> - (* We never assign to the array. So, no need to change the const. But - * we must change it on the base type *) - let bt' = stripConstLocalType bt in - if bt' != bt then TArray(bt', leno, a) else t - - | TComp(ci, a) -> - (* Must change both this structure as well as its fields *) - List.iter - (fun f -> - let t' = stripConstLocalType f.ftype in - if t' != f.ftype then begin - ignore (warnOpt "Stripping \"const\" from field %s of %s\n" - f.fname (compFullName ci)); - f.ftype <- t' - end) - ci.cfields; - let a' = dc a in if a != a' then TComp(ci, a') else t - - (* We never assign functions either *) - | TFun(rt, args, va, a) -> t - | TVoid _ -> E.s (bug "cabs2cil: stripConstLocalType: void") - | TBuiltin_va_list a -> - let a' = dc a in if a != a' then TBuiltin_va_list a' else t - - -let constFoldTypeVisitor = object (self) - inherit nopCilVisitor - method vtype t: typ visitAction = - match t with - TArray(bt, Some len, a) -> - let len' = constFold true len in - ChangeDoChildrenPost ( - TArray(bt, Some len', a), - (fun x -> x) - ) - | _ -> DoChildren -end - -(* Const-fold any expressions that appear as array lengths in this type *) -let constFoldType (t:typ) : typ = - visitCilType constFoldTypeVisitor t - - - -(* Create a new temporary variable *) -let newTempVar typ = - if !currentFunctionFDEC == dummyFunDec then - E.s (bug "newTempVar called outside a function"); -(* ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *) - let t' = stripConstLocalType typ in - (* Start with the name "tmp". The alpha converter will fix it *) - let vi = makeVarinfo false "tmp" t' in - alphaConvertVarAndAddToEnv false vi (* Do not add to the environment *) -(* - { vname = "tmp"; (* addNewVar will make the name fresh *) - vid = newVarId "tmp" false; - vglob = false; - vtype = t'; - vdecl = locUnknown; - vinline = false; - vattr = []; - vaddrof = false; - vreferenced = false; (* sm *) - vstorage = NoStorage; - } -*) - -let mkAddrOfAndMark ((b, off) as lval) : exp = - (* Mark the vaddrof flag if b is a variable *) - (match b with - Var vi -> vi.vaddrof <- true - | _ -> ()); - mkAddrOf lval - -(* Call only on arrays *) -let mkStartOfAndMark ((b, off) as lval) : exp = - (* Mark the vaddrof flag if b is a variable *) - (match b with - Var vi -> vi.vaddrof <- true - | _ -> ()); - let res = StartOf lval in - res - - - - (* Keep a set of self compinfo for composite types *) -let compInfoNameEnv : (string, compinfo) H.t = H.create 113 -let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113 - - -let lookupTypeNoError (kind: string) - (n: string) : typ * location = - let kn = kindPlusName kind n in - match H.find env kn with - EnvTyp t, l -> t, l - | _ -> raise Not_found - -let lookupType (kind: string) - (n: string) : typ * location = - try - lookupTypeNoError kind n - with Not_found -> - E.s (error "Cannot find type %s (kind:%s)\n" n kind) - -(* Create the self ref cell and add it to the map. Return also an indication - * if this is a new one. *) -let createCompInfo (iss: bool) (n: string) : compinfo * bool = - (* Add to the self cell set *) - let key = (if iss then "struct " else "union ") ^ n in - try - H.find compInfoNameEnv key, false (* Only if not already in *) - with Not_found -> begin - (* Create a compinfo. This will have "cdefined" false. *) - let res = mkCompInfo iss n (fun _ -> []) [] in - H.add compInfoNameEnv key res; - res, true - end - -(* Create the self ref cell and add it to the map. Return an indication - * whether this is a new one. *) -let createEnumInfo (n: string) : enuminfo * bool = - (* Add to the self cell set *) - try - H.find enumInfoNameEnv n, false (* Only if not already in *) - with Not_found -> begin - (* Create a enuminfo *) - let enum = { ename = n; eitems = []; - eattr = []; ereferenced = false; } in - H.add enumInfoNameEnv n enum; - enum, true - end - - - (* kind is either "struct" or "union" or "enum" and n is a name *) -let findCompType (kind: string) (n: string) (a: attributes) = - let makeForward () = - (* This is a forward reference, either because we have not seen this - * struct already or because we want to create a version with different - * attributes *) - if kind = "enum" then - let enum, isnew = createEnumInfo n in - if isnew then - cabsPushGlobal (GEnumTagDecl (enum, !currentLoc)); - TEnum (enum, a) - else - let iss = if kind = "struct" then true else false in - let self, isnew = createCompInfo iss n in - if isnew then - cabsPushGlobal (GCompTagDecl (self, !currentLoc)); - TComp (self, a) - in - try - let old, _ = lookupTypeNoError kind n in (* already defined *) - let olda = typeAttrs old in - if Util.equals olda a then old else makeForward () - with Not_found -> makeForward () - - -(* A simple visitor that searchs a statement for labels *) -class canDropStmtClass pRes = object - inherit nopCilVisitor - - method vstmt s = - if s.labels != [] then - (pRes := false; SkipChildren) - else - if !pRes then DoChildren else SkipChildren - - method vinst _ = SkipChildren - method vexpr _ = SkipChildren - -end -let canDropStatement (s: stmt) : bool = - let pRes = ref true in - let vis = new canDropStmtClass pRes in - ignore (visitCilStmt vis s); - !pRes - -(**** Occasionally we see structs with no name and no fields *) - - -module BlockChunk = - struct - type chunk = { - stmts: stmt list; - postins: instr list; (* Some instructions to append at - * the ends of statements (in - * reverse order) *) - (* A list of case statements visible at the - * outer level *) - cases: (label * stmt) list - } - - let d_chunk () (c: chunk) = - dprintf "@[{ @[%a@] };@?%a@]" - (docList ~sep:(chr ';') (d_stmt ())) c.stmts - (docList ~sep:(chr ';') (d_instr ())) (List.rev c.postins) - - let empty = - { stmts = []; postins = []; cases = []; } - - let isEmpty (c: chunk) = - c.postins == [] && c.stmts == [] - - let isNotEmpty (c: chunk) = not (isEmpty c) - - let i2c (i: instr) = - { empty with postins = [i] } - - (* Occasionally, we'll have to push postins into the statements *) - let pushPostIns (c: chunk) : stmt list = - if c.postins = [] then c.stmts - else - let rec toLast = function - [{skind=Instr il} as s] as stmts -> - s.skind <- Instr (il @ (List.rev c.postins)); - stmts - - | [] -> [mkStmt (Instr (List.rev c.postins))] - - | a :: rest -> a :: toLast rest - in - compactStmts (toLast c.stmts) - - - let c2block (c: chunk) : block = - { battrs = []; - bstmts = pushPostIns c; - } - - (* Add an instruction at the end. Never refer to this instruction again - * after you call this *) - let (+++) (c: chunk) (i : instr) = - {c with postins = i :: c.postins} - - (* Append two chunks. Never refer to the original chunks after you call - * this. And especially never share c2 with somebody else *) - let (@@) (c1: chunk) (c2: chunk) = - { stmts = compactStmts (pushPostIns c1 @ c2.stmts); - postins = c2.postins; - cases = c1.cases @ c2.cases; - } - - let skipChunk = empty - - let returnChunk (e: exp option) (l: location) : chunk = - { stmts = [ mkStmt (Return(e, l)) ]; - postins = []; - cases = [] - } - - let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk = - - { stmts = [ mkStmt(If(be, c2block t, c2block e, l))]; - postins = []; - cases = t.cases @ e.cases; - } - - (* We can duplicate a chunk if it has a few simple statements, and if - * it does not have cases *) - let duplicateChunk (c: chunk) = (* raises Failure if you should not - * duplicate this chunk *) - if not !allowDuplication then - raise (Failure "cannot duplicate: disallowed by user"); - if c.cases != [] then raise (Failure "cannot duplicate: has cases") else - let pCount = ref (List.length c.postins) in - { stmts = - List.map - (fun s -> - if s.labels != [] then - raise (Failure "cannot duplicate: has labels"); -(* - (match s.skind with - If _ | Switch _ | (*Loop _*) - While _ | DoWhile _ | For _ | Block _ -> - raise (Failure "cannot duplicate: complex stmt") - | Instr il -> - pCount := !pCount + List.length il - | _ -> incr pCount); - if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr")); -*) - (* We can just copy it because there is nothing to share here. - * Except maybe for the ref cell in Goto but it is Ok to share - * that, I think *) - { s with sid = s.sid}) c.stmts; - postins = c.postins; (* There is no shared stuff in instructions *) - cases = [] - } -(* - let duplicateChunk (c: chunk) = - if isEmpty c then c else raise (Failure ("cannot duplicate: isNotEmpty")) -*) - (* We can drop a chunk if it does not have labels inside *) - let canDrop (c: chunk) = - List.for_all canDropStatement c.stmts - -(* - let loopChunk (body: chunk) : chunk = - (* Make the statement *) - let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in - { stmts = [ loop (* ; n *) ]; - postins = []; - cases = body.cases; - } -*) - - let whileChunk (e: exp) (body: chunk) : chunk = - let loop = mkStmt (While (e, c2block body, !currentLoc)) in - - { stmts = [ loop ]; - postins = []; - cases = body.cases; - } - - let doWhileChunk (e: exp) (body: chunk) : chunk = - let loop = mkStmt (DoWhile (e, c2block body, !currentLoc)) in - - { stmts = [ loop ]; - postins = []; - cases = body.cases; - } - - let forChunk (bInit: chunk) (e: exp) (bIter: chunk) - (body: chunk) : chunk = - let loop = mkStmt (For (c2block bInit, e, c2block bIter, - c2block body, !currentLoc)) in - - { stmts = [ loop ]; - postins = []; - cases = body.cases; - } - - let breakChunk (l: location) : chunk = - { stmts = [ mkStmt (Break l) ]; - postins = []; - cases = []; - } - - let continueChunk (l: location) : chunk = - { stmts = [ mkStmt (Continue l) ]; - postins = []; - cases = [] - } - - (* Keep track of the gotos *) - let backPatchGotos : (string, stmt ref list ref) H.t = H.create 17 - let addGoto (lname: string) (bref: stmt ref) : unit = - let gotos = - try - H.find backPatchGotos lname - with Not_found -> begin - let gotos = ref [] in - H.add backPatchGotos lname gotos; - gotos - end - in - gotos := bref :: !gotos - - (* Keep track of the labels *) - let labelStmt : (string, stmt) H.t = H.create 17 - let initLabels () = - H.clear backPatchGotos; - H.clear labelStmt - - let resolveGotos () = - H.iter - (fun lname gotos -> - try - let dest = H.find labelStmt lname in - List.iter (fun gref -> gref := dest) !gotos - with Not_found -> begin - E.s (error "Label %s not found\n" lname) - end) - backPatchGotos - - (* Get the first statement in a chunk. Might need to change the - * statements in the chunk *) - let getFirstInChunk (c: chunk) : stmt * stmt list = - (* Get the first statement and add the label to it *) - match c.stmts with - s :: _ -> s, c.stmts - | [] -> (* Add a statement *) - let n = mkEmptyStmt () in - n, n :: c.stmts - - let consLabel (l: string) (c: chunk) (loc: location) - (in_original_program_text : bool) : chunk = - (* Get the first statement and add the label to it *) - let labstmt, stmts' = getFirstInChunk c in - (* Add the label *) - labstmt.labels <- Label (l, loc, in_original_program_text) :: - labstmt.labels; - H.add labelStmt l labstmt; - if c.stmts == stmts' then c else {c with stmts = stmts'} - - let s2c (s:stmt) : chunk = - { stmts = [ s ]; - postins = []; - cases = []; - } - - let gotoChunk (ln: string) (l: location) : chunk = - let gref = ref dummyStmt in - addGoto ln gref; - { stmts = [ mkStmt (Goto (gref, l)) ]; - postins = []; - cases = []; - } - - let caseRangeChunk (el: exp list) (l: location) (next: chunk) = - let fst, stmts' = getFirstInChunk next in - let labels = List.map (fun e -> Case (e, l)) el in - let cases = List.map (fun l -> (l, fst)) labels in - fst.labels <- labels @ fst.labels; - { next with stmts = stmts'; cases = cases @ next.cases} - - let defaultChunk (l: location) (next: chunk) = - let fst, stmts' = getFirstInChunk next in - let lb = Default l in - fst.labels <- lb :: fst.labels; - { next with stmts = stmts'; cases = (lb, fst) :: next.cases} - - - let switchChunk (e: exp) (body: chunk) (l: location) = - (* Make the statement *) - let switch = mkStmt (Switch (e, c2block body, - List.map (fun (_, s) -> s) body.cases, - l)) in - { stmts = [ switch (* ; n *) ]; - postins = []; - cases = []; - } - - let mkFunctionBody (c: chunk) : block = - resolveGotos (); initLabels (); - if c.cases <> [] then - E.s (error "Switch cases not inside a switch statement\n"); - c2block c - - end - -open BlockChunk - - -(************ Labels ***********) -(* -(* Since we turn dowhile and for loops into while we need to take care in - * processing the continue statement. For each loop that we enter we place a - * marker in a list saying what kinds of loop it is. When we see a continue - * for a Non-while loop we must generate a label for the continue *) -type loopstate = - While - | NotWhile of string ref - -let continues : loopstate list ref = ref [] - -let startLoop iswhile = - continues := (if iswhile then While else NotWhile (ref "")) :: !continues -*) - -(* We need to take care while processing the continue statement... - * For each loop that we enter we place a marker in a list saying what - * chunk of code we must duplicate before each continue statement - * in order to preserve the semantics. *) -type loopMarker = - | DuplicateBeforeContinue of chunk - | ContinueUnchanged - -let continues : loopMarker list ref = ref [] - -let startLoop lstate = - continues := lstate :: !continues - -let continueDuplicateChunk (l: location) : chunk = - match !continues with - | [] -> E.s (error "continue not in a loop") - | DuplicateBeforeContinue c :: _ -> c @@ continueChunk l - | ContinueUnchanged :: _ -> continueChunk l - -(* Sometimes we need to create new label names *) -let newLabelName (base: string) = fst (newAlphaName false "label" base) - -(* -let continueOrLabelChunk (l: location) : chunk = - match !continues with - [] -> E.s (error "continue not in a loop") - | While :: _ -> continueChunk l - | NotWhile lr :: _ -> - if !lr = "" then begin - lr := newLabelName "__Cont" - end; - gotoChunk !lr l - -let consLabContinue (c: chunk) = - match !continues with - [] -> E.s (error "labContinue not in a loop") - | While :: rest -> c - | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false -*) - -let exitLoop () = - match !continues with - [] -> E.s (error "exit Loop not in a loop") - | _ :: rest -> continues := rest - - -(* In GCC we can have locally declared labels. *) -let genNewLocalLabel (l: string) = - (* Call the newLabelName to register the label name in the alpha conversion - * table. *) - let l' = newLabelName l in - (* Add it to the environment *) - addLocalToEnv (kindPlusName "label" l) (EnvLabel l'); - l' - -let lookupLabel (l: string) = - try - match H.find env (kindPlusName "label" l) with - EnvLabel l', _ -> l' - | _ -> raise Not_found - with Not_found -> - l - - -(** ALLOCA ***) -let allocaFun () = - let name = - if !msvcMode then "alloca" - (* Use __builtin_alloca where possible, because this can be used - even when gcc is invoked with -fno-builtin *) - else "__builtin_alloca" - in - let fdec = emptyFunction name in - fdec.svar.vtype <- - TFun(voidPtrType, Some [ ("len", !typeOfSizeOf, []) ], false, []); - fdec.svar - -(* Maps local variables that are variable sized arrays to the expression that - * denotes their length *) -let varSizeArrays : exp IH.t = IH.create 17 - -(**** EXP actions ***) -type expAction = - ADrop (* Drop the result. Only the - * side-effect is interesting *) - | ASet of lval * typ (* Put the result in a given lval, - * provided it matches the type. The - * type is the type of the lval. *) - | AExp of typ option (* Return the exp as usual. - * Optionally we can specify an - * expected type. This is useful for - * constants. The expected type is - * informational only, we do not - * guarantee that the converted - * expression has that type.You must - * use a doCast afterwards to make - * sure. *) - | AExpLeaveArrayFun (* Do it like an expression, but do - * not convert arrays of functions - * into pointers *) - - -(*** Result of compiling conditional expressions *) -type condExpRes = - CEExp of chunk * exp (* Do a chunk and then an expression *) - | CEAnd of condExpRes * condExpRes - | CEOr of condExpRes * condExpRes - | CENot of condExpRes - -(******** CASTS *********) -let integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) - match unrollType t with - (* We assume that an IInt can hold even an IUShort *) - TInt ((IShort|IUShort|IChar|ISChar|IUChar), a) -> TInt(IInt, a) - | TInt _ -> t - | TEnum (_, a) -> TInt(IInt, a) - | t -> E.s (error "integralPromotion: not expecting %a" d_type t) - - -let arithmeticConversion (* c.f. ISO 6.3.1.8 *) - (t1: typ) - (t2: typ) : typ = - let checkToInt _ = () in (* dummies for now *) - let checkToFloat _ = () in - match unrollType t1, unrollType t2 with - TFloat(FLongDouble, _), _ -> checkToFloat t2; t1 - | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2 - | TFloat(FDouble, _), _ -> checkToFloat t2; t1 - | _, TFloat (FDouble, _) -> checkToFloat t1; t2 - | TFloat(FFloat, _), _ -> checkToFloat t2; t1 - | _, TFloat (FFloat, _) -> checkToFloat t1; t2 - | _, _ -> begin - let t1' = integralPromotion t1 in - let t2' = integralPromotion t2 in - match unrollType t1', unrollType t2' with - TInt(IULongLong, _), _ -> checkToInt t2'; t1' - | _, TInt(IULongLong, _) -> checkToInt t1'; t2' - - (* We assume a long long is always larger than a long *) - | TInt(ILongLong, _), _ -> checkToInt t2'; t1' - | _, TInt(ILongLong, _) -> checkToInt t1'; t2' - - | TInt(IULong, _), _ -> checkToInt t2'; t1' - | _, TInt(IULong, _) -> checkToInt t1'; t2' - - - | TInt(ILong,_), TInt(IUInt,_) - when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[]) - | TInt(IUInt,_), TInt(ILong,_) - when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[]) - - | TInt(ILong, _), _ -> checkToInt t2'; t1' - | _, TInt(ILong, _) -> checkToInt t1'; t2' - - | TInt(IUInt, _), _ -> checkToInt t2'; t1' - | _, TInt(IUInt, _) -> checkToInt t1'; t2' - - | TInt(IInt, _), TInt (IInt, _) -> t1' - - | _, _ -> E.s (error "arithmeticConversion") - end - - -(* Specify whether the cast is from the source code *) -let rec castTo ?(fromsource=false) - (ot : typ) (nt : typ) (e : exp) : (typ * exp ) = -(* - ignore (E.log "%t: castTo:%s %a->%a\n" - d_thisloc - (if fromsource then "(source)" else "") - d_type ot d_type nt); -*) - if not fromsource && Util.equals (typeSig ot) (typeSig nt) then - (* Do not put the cast if it is not necessary, unless it is from the - * source. *) - (ot, e) - else begin - let result = (nt, - if !insertImplicitCasts || fromsource then mkCastT e ot nt else e) in -(* - ignore (E.log "castTo: ot=%a nt=%a\n result is %a\n" - d_type ot d_type nt - d_plainexp (snd result)); -*) - (* Now see if we can have a cast here *) - match ot, nt with - TNamed(r, _), _ -> castTo ~fromsource:fromsource r.ttype nt e - | _, TNamed(r, _) -> castTo ~fromsource:fromsource ot r.ttype e - | TInt(ikindo,_), TInt(ikindn,_) -> - (* We used to ignore attributes on integer-integer casts. Not anymore *) - (* if ikindo = ikindn then (nt, e) else *) - result - - | TPtr (told, _), TPtr(tnew, _) -> result - - | TInt _, TPtr _ -> result - - | TPtr _, TInt _ -> result - - | TArray _, TPtr _ -> result - - | TArray(t1,_,_), TArray(t2,None,_) when Util.equals (typeSig t1) (typeSig t2) -> (nt, e) - - | TPtr _, TArray(_,_,_) -> (nt, e) - - | TEnum _, TInt _ -> result - | TFloat _, (TInt _|TEnum _) -> result - | (TInt _|TEnum _), TFloat _ -> result - | TFloat _, TFloat _ -> result - | TInt _, TEnum _ -> result - | TEnum _, TEnum _ -> result - - | TEnum _, TPtr _ -> result - | TBuiltin_va_list _, (TInt _ | TPtr _) -> - result - - | (TInt _ | TPtr _), TBuiltin_va_list _ -> - ignore (warnOpt "Casting %a to __builtin_va_list" d_type ot); - result - - | TPtr _, TEnum _ -> - ignore (warnOpt "Casting a pointer into an enumeration type"); - result - - (* The expression is evaluated for its side-effects *) - | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> - (ot, e) - - (* Even casts between structs are allowed when we are only - * modifying some attributes *) - | TComp (comp1, a1), TComp (comp2, a2) when comp1.ckey = comp2.ckey -> - (nt, e) - - (** If we try to pass a transparent union value to a function - * expecting a transparent union argument, the argument type would - * have been changed to the type of the first argument, and we'll - * see a cast from a union to the type of the first argument. Turn - * that into a field access *) - | TComp(tunion, a1), nt -> begin - match isTransparentUnion ot with - None -> E.s (error "castTo %a -> %a@!" d_type ot d_type nt) - | Some fstfield -> begin - (* We do it now only if the expression is an lval *) - let e' = - match e with - Lval lv -> - Lval (addOffsetLval (Field(fstfield, NoOffset)) lv) - | _ -> E.s (unimp "castTo: transparent union expression is not an lval: %a\n" d_exp e) - in - (* Continue casting *) - castTo ~fromsource:fromsource fstfield.ftype nt e' - end - end - | _ -> E.s (error "cabs2cil: castTo %a -> %a@!" d_type ot d_type nt) - end - - -(* A cast that is used for conditional expressions. Pointers are Ok *) -let checkBool (ot : typ) (e : exp) : bool = - match unrollType ot with - TInt _ -> true - | TPtr _ -> true - | TEnum _ -> true - | TFloat _ -> true - | _ -> E.s (error "castToBool %a" d_type ot) - -(* Given an expression that is being coerced to bool, - is it a nonzero constant? *) -let rec isConstTrue (e:exp): bool = - match e with - | Const(CInt64 (n,_,_)) -> n <> Int64.zero - | Const(CChr c) -> 0 <> Char.code c - | Const(CStr _ | CWStr _) -> true - | Const(CReal(f, _, _)) -> f <> 0.0; - | CastE(_, e) -> isConstTrue e - | _ -> false - -(* Given an expression that is being coerced to bool, is it zero? - This is a more general version of Cil.isZero, which only handles integers. - On constant expressions, either isConstTrue or isConstFalse will hold. *) -let rec isConstFalse (e:exp): bool = - match e with - | Const(CInt64 (n,_,_)) -> n = Int64.zero - | Const(CChr c) -> 0 = Char.code c - | Const(CReal(f, _, _)) -> f = 0.0; - | CastE(_, e) -> isConstFalse e - | _ -> false - - - -(* We have our own version of addAttributes that does not allow duplicates *) -let cabsAddAttributes al0 (al: attributes) : attributes = - if al0 == [] then al else - List.fold_left - (fun acc (Attr(an, _) as a) -> - (* See if the attribute is already in there *) - match filterAttributes an acc with - [] -> addAttribute a acc (* Nothing with that name *) - | a' :: _ -> - if Util.equals a a' then - acc (* Already in *) - else begin - ignore (warnOpt - "Duplicate attribute %a along with %a" - d_attr a d_attr a'); - (* let acc' = dropAttribute an acc in *) - (** Keep both attributes *) - addAttribute a acc - end) - al - al0 - -let cabsTypeAddAttributes a0 t = - begin - match a0 with - | [] -> - (* no attributes, keep same type *) - t - | _ -> - (* anything else: add a0 to existing attributes *) - let add (a: attributes) = cabsAddAttributes a0 a in - match t with - TVoid a -> TVoid (add a) - | TInt (ik, a) -> - (* Here we have to watch for the mode attribute *) -(* sm: This stuff is to handle a GCC extension where you can request integers*) -(* of specific widths using the "mode" attribute syntax; for example: *) -(* typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ; *) -(* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the *) -(* 32 bits you'd guess if you didn't know about "mode". The relevant *) -(* testcase is test/small2/mode_sizes.c, and it was inspired by my *) -(* /usr/include/sys/types.h. *) -(* *) -(* A consequence of this handling is that we throw away the mode *) -(* attribute, which we used to go out of our way to avoid printing anyway.*) - let ik', a0' = - (* Go over the list of new attributes and come back with a - * filtered list and a new integer kind *) - List.fold_left - (fun (ik', a0') a0one -> - match a0one with - Attr("mode", [ACons(mode,[])]) -> begin - (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n" - mode (* #$@!#@ ML! d_type t *) )); - (* the cases below encode the 32-bit assumption.. *) - match (ik', mode) with - | (IInt, "__QI__") -> (IChar, a0') - | (IInt, "__byte__") -> (IChar, a0') - | (IInt, "__HI__") -> (IShort, a0') - | (IInt, "__SI__") -> (IInt, a0') (* same as t *) - | (IInt, "__word__") -> (IInt, a0') - | (IInt, "__pointer__") -> (IInt, a0') - | (IInt, "__DI__") -> (ILongLong, a0') - - | (IUInt, "__QI__") -> (IUChar, a0') - | (IUInt, "__byte__") -> (IUChar, a0') - | (IUInt, "__HI__") -> (IUShort, a0') - | (IUInt, "__SI__") -> (IUInt, a0') - | (IUInt, "__word__") -> (IUInt, a0') - | (IUInt, "__pointer__")-> (IUInt, a0') - | (IUInt, "__DI__") -> (IULongLong, a0') - - | _ -> - (ignore (error "GCC width mode %s applied to unexpected type, or unexpected mode" - mode)); - (ik', a0one :: a0') - - end - | _ -> (ik', a0one :: a0')) - (ik, []) - a0 - in - TInt (ik', cabsAddAttributes a0' a) - - | TFloat (fk, a) -> TFloat (fk, add a) - | TEnum (enum, a) -> TEnum (enum, add a) - | TPtr (t, a) -> TPtr (t, add a) - | TArray (t, l, a) -> TArray (t, l, add a) - | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) - | TComp (comp, a) -> TComp (comp, add a) - | TNamed (t, a) -> TNamed (t, add a) - | TBuiltin_va_list a -> TBuiltin_va_list (add a) - end - - -(* Do types *) - (* Combine the types. Raises the Failure exception with an error message. - * isdef says whether the new type is for a definition *) -type combineWhat = - CombineFundef (* The new definition is for a function definition. The old - * is for a prototype *) - | CombineFunarg (* Comparing a function argument type with an old prototype - * arg *) - | CombineFunret (* Comparing the return of a function with that from an old - * prototype *) - | CombineOther - -(* We sometimes want to succeed in combining two structure types that are - * identical except for the names of the structs. We keep a list of types - * that are known to be equal *) -let isomorphicStructs : (string * string, bool) H.t = H.create 15 - -let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = - match oldt, t with - | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a) - | TInt (oldik, olda), TInt (ik, a) -> - let combineIK oldk k = - if oldk = k then oldk else - (* GCC allows a function definition to have a more precise integer - * type than a prototype that says "int" *) - if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 - && (what = CombineFunarg || what = CombineFunret) then - k - else - raise (Failure "different integer types") - in - TInt (combineIK oldik ik, cabsAddAttributes olda a) - | TFloat (oldfk, olda), TFloat (fk, a) -> - let combineFK oldk k = - if oldk = k then oldk else - (* GCC allows a function definition to have a more precise integer - * type than a prototype that says "double" *) - if not !msvcMode && oldk = FDouble && k = FFloat - && (what = CombineFunarg || what = CombineFunret) then - k - else - raise (Failure "different floating point types") - in - TFloat (combineFK oldfk fk, cabsAddAttributes olda a) - | TEnum (_, olda), TEnum (ei, a) -> - TEnum (ei, cabsAddAttributes olda a) - - (* Strange one. But seems to be handled by GCC *) - | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, - cabsAddAttributes olda a) - (* Strange one. But seems to be handled by GCC *) - | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a) - - - | TComp (oldci, olda) , TComp (ci, a) -> - if oldci.cstruct <> ci.cstruct then - raise (Failure "different struct/union types"); - let comb_a = cabsAddAttributes olda a in - if oldci.cname = ci.cname then - TComp (oldci, comb_a) - else - (* Now maybe they are actually the same *) - if H.mem isomorphicStructs (oldci.cname, ci.cname) then - (* We know they are the same *) - TComp (oldci, comb_a) - else begin - (* If one has 0 fields (undefined) while the other has some fields - * we accept it *) - let oldci_nrfields = List.length oldci.cfields in - let ci_nrfields = List.length ci.cfields in - if oldci_nrfields = 0 then - TComp (ci, comb_a) - else if ci_nrfields = 0 then - TComp (oldci, comb_a) - else begin - (* Make sure that at least they have the same number of fields *) - if oldci_nrfields <> ci_nrfields then begin -(* - ignore (E.log "different number of fields: %s had %d and %s had %d\n" - oldci.cname oldci_nrfields - ci.cname ci_nrfields); -*) - raise (Failure "different structs(number of fields)"); - end; - (* Assume they are the same *) - H.add isomorphicStructs (oldci.cname, ci.cname) true; - H.add isomorphicStructs (ci.cname, oldci.cname) true; - (* Check that the fields are isomorphic and watch for Failure *) - (try - List.iter2 (fun oldf f -> - if oldf.fbitfield <> f.fbitfield then - raise (Failure "different structs(bitfield info)"); - if oldf.fattr <> f.fattr then - raise (Failure "different structs(field attributes)"); - (* Make sure the types are compatible *) - ignore (combineTypes CombineOther oldf.ftype f.ftype); - ) oldci.cfields ci.cfields - with Failure _ as e -> begin - (* Our assumption was wrong. Forget the isomorphism *) - ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n" - oldci.cname ci.cname); - H.remove isomorphicStructs (oldci.cname, ci.cname); - H.remove isomorphicStructs (ci.cname, oldci.cname); - raise e - end); - (* We get here if we succeeded *) - TComp (oldci, comb_a) - end - end - - | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> - let newbt = combineTypes CombineOther oldbt bt in - let newsz = - match oldsz, sz with - None, Some _ -> sz - | Some _, None -> oldsz - | None, None -> sz - | Some oldsz', Some sz' -> - (* They are not structurally equal. But perhaps they are equal if - * we evaluate them. Check first machine independent comparison *) - let checkEqualSize (machdep: bool) = - Util.equals (constFold machdep oldsz') - (constFold machdep sz') - in - if checkEqualSize false then - oldsz - else if checkEqualSize true then begin - ignore (warn "Array type comparison succeeds only based on machine-dependent constant evaluation: %a and %a\n" - d_exp oldsz' d_exp sz'); - oldsz - end else - raise (Failure "different array lengths") - - in - TArray (newbt, newsz, cabsAddAttributes olda a) - - | TPtr (oldbt, olda), TPtr (bt, a) -> - TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a) - - | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t - - | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> - let newrt = combineTypes - (if what = CombineFundef then CombineFunret else CombineOther) - oldrt rt - in - if oldva != va then - raise (Failure "diferent vararg specifiers"); - (* If one does not have arguments, believe the one with the - * arguments *) - let newargs = - if oldargs = None then args else - if args = None then oldargs else - let oldargslist = argsToList oldargs in - let argslist = argsToList args in - if List.length oldargslist <> List.length argslist then - raise (Failure "different number of arguments") - else begin - (* Go over the arguments and update the old ones with the - * adjusted types *) - Some - (List.map2 - (fun (on, ot, oa) (an, at, aa) -> - (* Update the names. Always prefer the new name. This is - * very important if the prototype uses different names than - * the function definition. *) - let n = if an <> "" then an else on in - let t = - combineTypes - (if what = CombineFundef then - CombineFunarg else CombineOther) - ot at - in - let a = addAttributes oa aa in - (n, t, a)) - oldargslist argslist) - end - in - TFun (newrt, newargs, oldva, cabsAddAttributes olda a) - - | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname -> - TNamed (oldt, cabsAddAttributes olda a) - - | TBuiltin_va_list olda, TBuiltin_va_list a -> - TBuiltin_va_list (cabsAddAttributes olda a) - - (* Unroll first the new type *) - | _, TNamed (t, a) -> - let res = combineTypes what oldt t.ttype in - cabsTypeAddAttributes a res - - (* And unroll the old type as well if necessary *) - | TNamed (oldt, a), _ -> - let res = combineTypes what oldt.ttype t in - cabsTypeAddAttributes a res - - | _ -> raise (Failure "different type constructors") - - -(* Create and cache varinfo's for globals. Starts with a varinfo but if the - * global has been declared already it might come back with another varinfo. - * Returns the varinfo to use (might be the old one), and an indication - * whether the variable exists already in the environment *) -let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = - try (* See if already defined, in the global environment. We could also - * look it up in the whole environment but in that case we might see a - * local. This can happen when we declare an extern variable with - * global scope but we are in a local scope. *) - let oldvi, oldloc = lookupGlobalVar vi.vname in - (* It was already defined. We must reuse the varinfo. But clean up the - * storage. *) - let newstorage = (** See 6.2.2 *) - match oldvi.vstorage, vi.vstorage with - (* Extern and something else is that thing *) - | Extern, other - | other, Extern -> other - - | NoStorage, other - | other, NoStorage -> other - - - | _ -> - if vi.vstorage != oldvi.vstorage then - ignore (warn - "Inconsistent storage specification for %s. Previous declaration: %a" - vi.vname d_loc oldloc); - vi.vstorage - in - oldvi.vinline <- oldvi.vinline || vi.vinline; - oldvi.vstorage <- newstorage; - (* Union the attributes *) - oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr; - begin - try - oldvi.vtype <- - combineTypes - (if isadef then CombineFundef else CombineOther) - oldvi.vtype vi.vtype; - with Failure reason -> - ignore (E.log "old type = %a\n" d_plaintype oldvi.vtype); - ignore (E.log "new type = %a\n" d_plaintype vi.vtype); - E.s (error "Declaration of %s does not match previous declaration from %a (%s)." - vi.vname d_loc oldloc reason) - end; - - (* Found an old one. Keep the location always from the definition *) - if isadef then begin - oldvi.vdecl <- vi.vdecl; - end; - oldvi, true - - with Not_found -> begin (* A new one. *) - (* Announce the name to the alpha conversion table. This will not - * actually change the name of the vi. See the definition of - * alphaConvertVarAndAddToEnv *) - alphaConvertVarAndAddToEnv true vi, false - end - -let conditionalConversion (t2: typ) (t3: typ) : typ = - let tresult = (* ISO 6.5.15 *) - match unrollType t2, unrollType t3 with - (TInt _ | TEnum _ | TFloat _), - (TInt _ | TEnum _ | TFloat _) -> - arithmeticConversion t2 t3 - | TComp (comp2,_), TComp (comp3,_) - when comp2.ckey = comp3.ckey -> t2 - | TPtr(_, _), TPtr(TVoid _, _) -> t2 - | TPtr(TVoid _, _), TPtr(_, _) -> t3 - | TPtr _, TPtr _ when Util.equals (typeSig t2) (typeSig t3) -> t2 - | TPtr _, TInt _ -> t2 (* most likely comparison with 0 *) - | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *) - - (* When we compare two pointers of diffent type, we combine them - * using the same algorithm when combining multiple declarations of - * a global *) - | (TPtr _) as t2', (TPtr _ as t3') -> begin - try combineTypes CombineOther t2' t3' - with Failure msg -> begin - ignore (warn "A.QUESTION: %a does not match %a (%s)" - d_type (unrollType t2) d_type (unrollType t3) msg); - t2 (* Just pick one *) - end - end - | _, _ -> E.s (error "A.QUESTION for invalid combination of types") - in - tresult - -(* Some utilitites for doing initializers *) - -let debugInit = false - -type preInit = - | NoInitPre - | SinglePre of exp - | CompoundPre of int ref (* the maximum used index *) - * preInit array ref (* an array with initializers *) - -(* Instructions on how to handle designators *) -type handleDesignators = - | Handle (* Handle them yourself *) - | DoNotHandle (* Do not handle them your self *) - | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going - * into nested designators *) - | HandleFirst (* Handle only the first designator *) - -(* Set an initializer *) -let rec setOneInit (this: preInit) - (o: offset) (e: exp) : preInit = - match o with - NoOffset -> SinglePre e - | _ -> - let idx, (* Index in the current comp *) - restoff (* Rest offset *) = - match o with - | Index(Const(CInt64(i,_,_)), off) -> Int64.to_int i, off - | Field (f, off) -> - (* Find the index of the field *) - let rec loop (idx: int) = function - [] -> E.s (bug "Cannot find field %s" f.fname) - | f' :: _ when f'.fname = f.fname -> idx - | _ :: restf -> loop (idx + 1) restf - in - loop 0 f.fcomp.cfields, off - | _ -> E.s (bug "setOneInit: non-constant index") - in - let pMaxIdx, pArray = - match this with - NoInitPre -> (* No initializer so far here *) - ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre) - - | CompoundPre (pMaxIdx, pArray) -> - if !pMaxIdx < idx then begin - pMaxIdx := idx; - (* Maybe we also need to grow the array *) - let l = Array.length !pArray in - if l <= idx then begin - let growBy = max (max 32 (idx + 1 - l)) (l / 2) in - let newarray = Array.make (growBy + idx) NoInitPre in - Array.blit !pArray 0 newarray 0 l; - pArray := newarray - end - end; - pMaxIdx, pArray - | SinglePre e -> - E.s (unimp "Index %d is already initialized" idx) - in - assert (idx >= 0 && idx < Array.length !pArray); - let this' = setOneInit !pArray.(idx) restoff e in - !pArray.(idx) <- this'; - CompoundPre (pMaxIdx, pArray) - - -(* collect a CIL initializer, given the original syntactic initializer - * 'preInit'; this returns a type too, since initialization of an array - * with unspecified size actually changes the array's type - * (ANSI C, 6.7.8, para 22) *) -let rec collectInitializer - (this: preInit) - (thistype: typ) : (init * typ) = - if this = NoInitPre then (makeZeroInit thistype), thistype - else - match unrollType thistype, this with - | _ , SinglePre e -> SingleInit e, thistype - | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) -> - let (len: int), newtype = - (* normal case: use array's declared length, newtype=thistype *) - match leno with - Some len -> begin - match constFold true len with - Const(CInt64(ni, _, _)) when ni >= 0L -> - (Int64.to_int ni), TArray(bt,leno,at) - - | _ -> E.s (error "Array length is not a constant expression %a" - d_exp len) - end - | _ -> - (* unsized array case, length comes from initializers *) - (!pMaxIdx + 1, - TArray (bt, Some (integer (!pMaxIdx + 1)), at)) - in - if !pMaxIdx >= len then - E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n" - !pMaxIdx len); - (* len could be extremely big. So omit the last initializers, if they - * are many (more than 16) *) -(* - ignore (E.log "collectInitializer: len = %d, pMaxIdx= %d\n" - len !pMaxIdx); *) - let endAt = - if len - 1 > !pMaxIdx + 16 then - !pMaxIdx - else - len - 1 - in - (* Make one zero initializer to be used next *) - let oneZeroInit = makeZeroInit bt in - let rec collect (acc: (offset * init) list) (idx: int) = - if idx = -1 then acc - else - let thisi = - if idx > !pMaxIdx then oneZeroInit - else (fst (collectInitializer !pArray.(idx) bt)) - in - collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1) - in - - CompoundInit (newtype, collect [] endAt), newtype - - | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct -> - let rec collect (idx: int) = function - [] -> [] - | f :: restf -> - if f.fname = missingFieldName then - collect (idx + 1) restf - else - let thisi = - if idx > !pMaxIdx then - makeZeroInit f.ftype - else - collectFieldInitializer !pArray.(idx) f - in - (Field(f, NoOffset), thisi) :: collect (idx + 1) restf - in - CompoundInit (thistype, collect 0 comp.cfields), thistype - - | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct -> - (* Find the field to initialize *) - let rec findField (idx: int) = function - [] -> E.s (bug "collectInitializer: union") - | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> - findField (idx + 1) rest - | f :: _ when idx = !pMaxIdx -> - Field(f, NoOffset), - collectFieldInitializer !pArray.(idx) f - | _ -> E.s (error "Can initialize only one field for union") - in - if !msvcMode && !pMaxIdx != 0 then - ignore (warn "On MSVC we can initialize only the first field of a union"); - CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype - - | _ -> E.s (unimp "collectInitializer") - -and collectFieldInitializer - (this: preInit) - (f: fieldinfo) : init = - (* collect, and rewrite type *) - let init,newtype = (collectInitializer this f.ftype) in - f.ftype <- newtype; - init - - -type stackElem = - InArray of offset * typ * int * int ref (* offset of parent, base type, - * length, current index. If the - * array length is unspecified we - * use Int.max_int *) - | InComp of offset * compinfo * fieldinfo list (* offset of parent, - base comp, current fields *) - - -(* A subobject is given by its address. The address is read from the end of - * the list (the bottom of the stack), starting with the current object *) -type subobj = { mutable stack: stackElem list; (* With each stack element we - * store the offset of its - * PARENT *) - mutable eof: bool; (* The stack is empty and we reached the - * end *) - mutable soTyp: typ; (* The type of the subobject. Set using - * normalSubobj after setting stack. *) - mutable soOff: offset; (* The offset of the subobject. Set - * using normalSubobj after setting - * stack. *) - curTyp: typ; (* Type of current object. See ISO for - * the definition of the current object *) - curOff: offset; (* The offset of the current obj *) - host: varinfo; (* The host that we are initializing. - * For error messages *) - } - - -(* Make a subobject iterator *) -let rec makeSubobj - (host: varinfo) - (curTyp: typ) - (curOff: offset) = - let so = - { host = host; curTyp = curTyp; curOff = curOff; - stack = []; eof = false; - (* The next are fixed by normalSubobj *) - soTyp = voidType; soOff = NoOffset } in - normalSubobj so; - so - - (* Normalize a stack so the we always point to a valid subobject. Do not - * descend into type *) -and normalSubobj (so: subobj) : unit = - match so.stack with - [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp - (* The array is over *) - | InArray (parOff, bt, leno, current) :: rest -> - if leno = !current then begin (* The array is over *) - if debugInit then ignore (E.log "Past the end of array\n"); - so.stack <- rest; - advanceSubobj so - end else begin - so.soTyp <- bt; - so.soOff <- addOffset (Index(integer !current, NoOffset)) parOff - end - - (* The fields are over *) - | InComp (parOff, comp, nextflds) :: rest -> - if nextflds == [] then begin (* No more fields here *) - if debugInit then ignore (E.log "Past the end of structure\n"); - so.stack <- rest; - advanceSubobj so - end else begin - let fst = List.hd nextflds in - so.soTyp <- fst.ftype; - so.soOff <- addOffset (Field(fst, NoOffset)) parOff - end - - (* Advance to the next subobject. Always apply to a normalized object *) -and advanceSubobj (so: subobj) : unit = - if so.eof then E.s (bug "advanceSubobj past end"); - match so.stack with - | [] -> if debugInit then ignore (E.log "Setting eof to true\n"); - so.eof <- true - | InArray (parOff, bt, leno, current) :: rest -> - if debugInit then ignore (E.log " Advancing to [%d]\n" (!current + 1)); - (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *) - incr current; - normalSubobj so - - (* The fields are over *) - | InComp (parOff, comp, nextflds) :: rest -> - if debugInit then - ignore (E.log "Advancing past .%s\n" (List.hd nextflds).fname); - let flds' = try List.tl nextflds with _ -> E.s (bug "advanceSubobj") in - so.stack <- InComp(parOff, comp, flds') :: rest; - normalSubobj so - - - -(* Find the fields to initialize in a composite. *) -let fieldsToInit - (comp: compinfo) - (designator: string option) - : fieldinfo list = - (* Never look at anonymous fields *) - let flds1 = - List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in - let flds2 = - match designator with - None -> flds1 - | Some fn -> - let rec loop = function - [] -> E.s (error "Cannot find designated field %s" fn) - | (f :: _) as nextflds when f.fname = fn -> nextflds - | _ :: rest -> loop rest - in - loop flds1 - in - (* If it is a union we only initialize one field *) - match flds2 with - [] -> [] - | (f :: rest) as toinit -> - if comp.cstruct then toinit else [f] - - -let integerArrayLength (leno: exp option) : int = - match leno with - None -> max_int - | Some len -> begin - try lenOfArray leno - with LenOfArray -> - E.s (error "Initializing non-constant-length array\n length=%a\n" - d_exp len) - end - -(* sm: I'm sure something like this already exists, but ... *) -let isNone (o : 'a option) : bool = - match o with - | None -> true - | Some _ -> false - - -let annonCompFieldNameId = ref 0 -let annonCompFieldName = "__annonCompField" - - - -(* Utility ***) -let rec replaceLastInList - (lst: A.expression list) - (how: A.expression -> A.expression) : A.expression list= - match lst with - [] -> [] - | [e] -> [how e] - | h :: t -> h :: replaceLastInList t how - - - - - -let convBinOp (bop: A.binary_operator) : binop = - match bop with - A.ADD -> PlusA - | A.SUB -> MinusA - | A.MUL -> Mult - | A.DIV -> Div - | A.MOD -> Mod - | A.BAND -> BAnd - | A.BOR -> BOr - | A.XOR -> BXor - | A.SHL -> Shiftlt - | A.SHR -> Shiftrt - | A.EQ -> Eq - | A.NE -> Ne - | A.LT -> Lt - | A.LE -> Le - | A.GT -> Gt - | A.GE -> Ge - | _ -> E.s (error "convBinOp") - -(**** PEEP-HOLE optimizations ***) -let afterConversion (c: chunk) : chunk = - (* Now scan the statements and find Instr blocks *) - - (** We want to collapse sequences of the form "tmp = f(); v = tmp". This - * will help significantly with the handling of calls to malloc, where it - * is important to have the cast at the same place as the call *) - let collapseCallCast = function - Call(Some(Var vi, NoOffset), f, args, l), - Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _) - when (not vi.vglob && - String.length vi.vname >= 3 && - (* Watch out for the possibility that we have an implied cast in - * the call *) - (let tcallres = - match unrollType (typeOf f) with - TFun (rt, _, _, _) -> rt - | _ -> E.s (E.bug "Function call to a non-function") - in - Util.equals (typeSig tcallres) (typeSig vi.vtype) && - Util.equals (typeSig newt) (typeSig (typeOfLval destlv))) && - IH.mem callTempVars vi.vid && - vi' == vi) - -> Some [Call(Some destlv, f, args, l)] - | i1,i2 -> None - in - (* First add in the postins *) - let sl = pushPostIns c in - peepHole2 collapseCallCast sl; - { c with stmts = sl; postins = [] } - -(***** Try to suggest a name for the anonymous structures *) -let suggestAnonName (nl: A.name list) = - match nl with - [] -> "" - | (n, _, _, _) :: _ -> n - - -(** Optional constant folding of binary operations *) -let optConstFoldBinOp (machdep: bool) (bop: binop) - (e1: exp) (e2:exp) (t: typ) = - if !lowerConstants then - constFoldBinOp machdep bop e1 e2 t - else - BinOp(bop, e1, e2, t) - -(****** TYPE SPECIFIERS *******) -let rec doSpecList (suggestedAnonName: string) (* This string will be part of - * the names for anonymous - * structures and enums *) - (specs: A.spec_elem list) - (* Returns the base type, the storage, whether it is inline and the - * (unprocessed) attributes *) - : typ * storage * bool * A.attribute list = - (* Do one element and collect the type specifiers *) - let isinline = ref false in (* If inline appears *) - (* The storage is placed here *) - let storage : storage ref = ref NoStorage in - - (* Collect the attributes. Unfortunately, we cannot treat GCC - * __attributes__ and ANSI C const/volatile the same way, since they - * associate with structures differently. Specifically, ANSI - * qualifiers never apply to structures (ISO 6.7.3), whereas GCC - * attributes always do (GCC manual 4.30). Therefore, they are - * collected and processed separately. *) - let attrs : A.attribute list ref = ref [] in (* __attribute__, etc. *) - let cvattrs : A.cvspec list ref = ref [] in (* const/volatile *) - - let doSpecElem (se: A.spec_elem) - (acc: A.typeSpecifier list) - : A.typeSpecifier list = - match se with - A.SpecTypedef -> acc - | A.SpecInline -> isinline := true; acc - | A.SpecStorage st -> - if !storage <> NoStorage then - E.s (error "Multiple storage specifiers"); - let sto' = - match st with - A.NO_STORAGE -> NoStorage - | A.AUTO -> NoStorage - | A.REGISTER -> Register - | A.STATIC -> Static - | A.EXTERN -> Extern - in - storage := sto'; - acc - - | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc - | A.SpecAttr a -> attrs := a :: !attrs; acc - | A.SpecType ts -> ts :: acc - | A.SpecPattern _ -> E.s (E.bug "SpecPattern in cabs2cil input") - in - (* Now scan the list and collect the type specifiers. Preserve the order *) - let tspecs = List.fold_right doSpecElem specs [] in - - let tspecs' = - (* GCC allows a named type that appears first to be followed by things - * like "short", "signed", "unsigned" or "long". *) - match tspecs with - A.Tnamed n :: (_ :: _ as rest) when not !msvcMode -> - (* If rest contains "short" or "long" then drop the Tnamed *) - if List.exists (function A.Tshort -> true - | A.Tlong -> true | _ -> false) rest then - rest - else - tspecs - - | _ -> tspecs - in - (* Sort the type specifiers *) - let sortedspecs = - let order = function (* Don't change this *) - | A.Tvoid -> 0 - | A.Tsigned -> 1 - | A.Tunsigned -> 2 - | A.Tchar -> 3 - | A.Tshort -> 4 - | A.Tlong -> 5 - | A.Tint -> 6 - | A.Tint64 -> 7 - | A.Tfloat -> 8 - | A.Tdouble -> 9 - | _ -> 10 (* There should be at most one of the others *) - in - List.stable_sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs' - in - let getTypeAttrs () : A.attribute list = - (* Partitions the attributes in !attrs. - Type attributes are removed from attrs and returned, so that they - can go into the type definition. Name attributes are left in attrs, - so they will be returned by doSpecAttr and used in the variable - declaration. - Testcase: small1/attr9.c *) - let an, af, at = cabsPartitionAttributes ~default:AttrType !attrs in - attrs := an; (* Save the name attributes for later *) - if af <> [] then - E.s (error "Invalid position for function type attributes."); - at - in - - (* And now try to make sense of it. See ISO 6.7.2 *) - let bt = - match sortedspecs with - [A.Tvoid] -> TVoid [] - | [A.Tchar] -> TInt(IChar, []) - | [A.Tsigned; A.Tchar] -> TInt(ISChar, []) - | [A.Tunsigned; A.Tchar] -> TInt(IUChar, []) - - | [A.Tshort] -> TInt(IShort, []) - | [A.Tsigned; A.Tshort] -> TInt(IShort, []) - | [A.Tshort; A.Tint] -> TInt(IShort, []) - | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, []) - - | [A.Tunsigned; A.Tshort] -> TInt(IUShort, []) - | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, []) - - | [] -> TInt(IInt, []) - | [A.Tint] -> TInt(IInt, []) - | [A.Tsigned] -> TInt(IInt, []) - | [A.Tsigned; A.Tint] -> TInt(IInt, []) - - | [A.Tunsigned] -> TInt(IUInt, []) - | [A.Tunsigned; A.Tint] -> TInt(IUInt, []) - - | [A.Tlong] -> TInt(ILong, []) - | [A.Tsigned; A.Tlong] -> TInt(ILong, []) - | [A.Tlong; A.Tint] -> TInt(ILong, []) - | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, []) - - | [A.Tunsigned; A.Tlong] -> TInt(IULong, []) - | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, []) - - | [A.Tlong; A.Tlong] -> TInt(ILongLong, []) - | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, []) - | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) - | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) - - | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, []) - | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, []) - - (* int64 is to support MSVC *) - | [A.Tint64] -> TInt(ILongLong, []) - | [A.Tsigned; A.Tint64] -> TInt(ILongLong, []) - - | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, []) - - | [A.Tfloat] -> TFloat(FFloat, []) - | [A.Tdouble] -> TFloat(FDouble, []) - - | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, []) - - (* Now the other type specifiers *) - | [A.Tnamed n] -> begin - if n = "__builtin_va_list" && - Machdep.gccHas__builtin_va_list then begin - TBuiltin_va_list [] - end else - let t = - match lookupType "type" n with - (TNamed _) as x, _ -> x - | typ -> E.s (error "Named type %s is not mapped correctly\n" n) - in - t - end - - | [A.Tstruct (n, None, _)] -> (* A reference to a struct *) - if n = "" then E.s (error "Missing struct tag on incomplete struct"); - findCompType "struct" n [] - | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *) - let n' = - if n <> "" then n else anonStructName "struct" suggestedAnonName in - (* Use the (non-cv, non-name) attributes in !attrs now *) - let a = extraAttrs @ (getTypeAttrs ()) in - makeCompType true n' nglist (doAttributes a) - - | [A.Tunion (n, None, _)] -> (* A reference to a union *) - if n = "" then E.s (error "Missing union tag on incomplete union"); - findCompType "union" n [] - | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *) - let n' = - if n <> "" then n else anonStructName "union" suggestedAnonName in - (* Use the attributes now *) - let a = extraAttrs @ (getTypeAttrs ()) in - makeCompType false n' nglist (doAttributes a) - - | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *) - if n = "" then E.s (error "Missing enum tag on incomplete enum"); - findCompType "enum" n [] - - | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *) - let n' = - if n <> "" then n else anonStructName "enum" suggestedAnonName in - (* make a new name for this enumeration *) - let n'', _ = newAlphaName true "enum" n' in - - (* Create the enuminfo, or use one that was created already for a - * forward reference *) - let enum, _ = createEnumInfo n'' in - let a = extraAttrs @ (getTypeAttrs ()) in - enum.eattr <- doAttributes a; - let res = TEnum (enum, []) in - - (* sm: start a scope for the enum tag values, since they * - * can refer to earlier tags *) - enterScope (); - - (* as each name,value pair is determined, this is called *) - let rec processName kname (i: exp) loc rest = begin - (* add the name to the environment, but with a faked 'typ' field; - * we don't know the full type yet (since that includes all of the - * tag values), but we won't need them in here *) - addLocalToEnv kname (EnvEnum (i, res)); - - (* add this tag to the list so that it ends up in the real - * environment when we're finished *) - let newname, _ = newAlphaName true "" kname in - - (kname, (newname, i, loc)) :: loop (increm i 1) rest - end - - and loop i = function - [] -> [] - | (kname, A.NOTHING, cloc) :: rest -> - (* use the passed-in 'i' as the value, since none specified *) - processName kname i (convLoc cloc) rest - - | (kname, e, cloc) :: rest -> - (* constant-eval 'e' to determine tag value *) - let e' = getIntConstExp e in - let e' = - match isInteger (constFold true e') with - Some i -> if !lowerConstants then kinteger64 IInt i else e' - | _ -> E.s (error "Constant initializer %a not an integer" d_exp e') - in - processName kname e' (convLoc cloc) rest - in - - (* sm: now throw away the environment we built for eval'ing the enum - * tags, so we can add to the new one properly *) - exitScope (); - - let fields = loop zero eil in - (* Now set the right set of items *) - enum.eitems <- List.map (fun (_, x) -> x) fields; - (* Record the enum name in the environment *) - addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res); - (* And define the tag *) - cabsPushGlobal (GEnumTag (enum, !currentLoc)); - res - - - | [A.TtypeofE e] -> - let (c, e', t) = doExp false e AExpLeaveArrayFun in - let t' = - match e' with - StartOf(lv) -> typeOfLval lv - (* If this is a string literal, then we treat it as in sizeof*) - | Const (CStr s) -> begin - match typeOf e' with - TPtr(bt, _) -> (* This is the type of array elements *) - TArray(bt, Some (SizeOfStr s), []) - | _ -> E.s (bug "The typeOf a string is not a pointer type") - end - | _ -> t - in -(* - ignore (E.log "typeof(%a) = %a\n" d_exp e' d_plaintype t'); -*) - t' - - | [A.TtypeofT (specs, dt)] -> - let typ = doOnlyType specs dt in - typ - - | _ -> - E.s (error "Invalid combination of type specifiers") - in - bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs)) - -(* given some cv attributes, convert them into named attributes for - * uniform processing *) -and convertCVtoAttr (src: A.cvspec list) : A.attribute list = - match src with - | [] -> [] - | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl) - | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl) - | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl) - - -and makeVarInfoCabs - ~(isformal: bool) - ~(isglobal: bool) - (ldecl : location) - (bt, sto, inline, attrs) - (n,ndt,a) - : varinfo = - let vtype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in - if inline && not (isFunctionType vtype) then - ignore (error "inline for a non-function: %s" n); - let t = - if not isglobal && not isformal then begin - (* Sometimes we call this on the formal argument of a function with no - * arguments. Don't call stripConstLocalType in that case *) -(* ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *) - stripConstLocalType vtype - end else - vtype - in - let vi = makeVarinfo isglobal n t in - vi.vstorage <- sto; - vi.vattr <- nattr; - vi.vdecl <- ldecl; - - if false then - ignore (E.log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype); - - vi - -(* Process a local variable declaration and allow variable-sized arrays *) -and makeVarSizeVarInfo (ldecl : location) - spec_res - (n,ndt,a) - : varinfo * chunk * exp * bool = - if not !msvcMode then - match isVariableSizedArray ndt with - None -> - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt,a), empty, zero, false - | Some (ndt', se, len) -> - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt',a), se, len, true - else - makeVarInfoCabs ~isformal:false - ~isglobal:false - ldecl spec_res (n,ndt,a), empty, zero, false - -and doAttr (a: A.attribute) : attribute list = - (* Strip the leading and trailing underscore *) - let stripUnderscore (n: string) : string = - let l = String.length n in - let rec start i = - if i >= l then - E.s (error "Invalid attribute name %s" n); - if String.get n i = '_' then start (i + 1) else i - in - let st = start 0 in - let rec finish i = - (* We know that we will stop at >= st >= 0 *) - if String.get n i = '_' then finish (i - 1) else i - in - let fin = finish (l - 1) in - String.sub n st (fin - st + 1) - in - match a with - | (s, []) -> [Attr (stripUnderscore s, [])] - | (s, el) -> - - let rec attrOfExp (strip: bool) - ?(foldenum=true) - (a: A.expression) : attrparam = - match a with - A.VARIABLE n -> begin - let n' = if strip then stripUnderscore n else n in - (** See if this is an enumeration *) - try - if not foldenum then raise Not_found; - - match H.find env n' with - EnvEnum (tag, _), _ -> begin - match isInteger (constFold true tag) with - Some i64 when !lowerConstants -> AInt (Int64.to_int i64) - | _ -> ACons(n', []) - end - | _ -> ACons (n', []) - with Not_found -> ACons(n', []) - end - | A.CONSTANT (A.CONST_STRING s) -> AStr s - | A.CONSTANT (A.CONST_INT str) -> AInt (int_of_string str) - | A.CALL(A.VARIABLE n, args) -> begin - let n' = if strip then stripUnderscore n else n in - let ae' = List.map ae args in - ACons(n', ae') - end - | A.EXPR_SIZEOF e -> ASizeOfE (ae e) - | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt) - | A.EXPR_ALIGNOF e -> AAlignOfE (ae e) - | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt) - | A.BINARY(A.AND, aa1, aa2) -> - ABinOp(LAnd, ae aa1, ae aa2) - | A.BINARY(A.OR, aa1, aa2) -> - ABinOp(LOr, ae aa1, ae aa2) - | A.BINARY(abop, aa1, aa2) -> - ABinOp (convBinOp abop, ae aa1, ae aa2) - | A.UNARY(A.PLUS, aa) -> ae aa - | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa) - | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa) - | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa) - | A.MEMBEROF (e, s) -> ADot (ae e, s) - | _ -> - ignore (E.log "Invalid expression in attribute: "); - withCprint Cprint.print_expression a; - E.s (error "cabs2cil: invalid expression") - - and ae (e: A.expression) = attrOfExp false e in - - (* Sometimes we need to convert attrarg into attr *) - let arg2attr = function - | ACons (s, args) -> Attr (s, args) - | a -> - E.s (error "Invalid form of attribute: %a" - d_attrparam a); - in - if s = "__attribute__" then (* Just a wrapper for many attributes*) - List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el - else if s = "__blockattribute__" then (* Another wrapper *) - List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el - else if s = "__declspec" then - List.map (fun e -> arg2attr (attrOfExp false ~foldenum:false e)) el - else - [Attr(stripUnderscore s, List.map (attrOfExp ~foldenum:false false) el)] - -and doAttributes (al: A.attribute list) : attribute list = - List.fold_left (fun acc a -> cabsAddAttributes (doAttr a) acc) [] al - -(* A version of Cil.partitionAttributes that works on CABS attributes. - It would be better to use Cil.partitionAttributes instead to avoid - the extra doAttr conversions here, but that's hard to do in doSpecList.*) -and cabsPartitionAttributes - ~(default:attributeClass) - (attrs: A.attribute list) : - A.attribute list * A.attribute list * A.attribute list = - let rec loop (n,f,t) = function - [] -> n, f, t - | a :: rest -> - let kind = match doAttr a with - [] -> default - | Attr(an, _)::_ -> - (try H.find attributeHash an with Not_found -> default) - in - match kind with - AttrName _ -> loop (a::n, f, t) rest - | AttrFunType _ -> - loop (n, a::f, t) rest - | AttrType -> loop (n, f, a::t) rest - in - loop ([], [], []) attrs - - - -and doType (nameortype: attributeClass) (* This is AttrName if we are doing - * the type for a name, or AttrType - * if we are doing this type in a - * typedef *) - (bt: typ) (* The base type *) - (dt: A.decl_type) - (* Returns the new type and the accumulated name (or type attribute - if nameoftype = AttrType) attributes *) - : typ * attribute list = - - (* Now do the declarator type. But remember that the structure of the - * declarator type is as printed, meaning that it is the reverse of the - * right one *) - let rec doDeclType (bt: typ) (acc: attribute list) = function - A.JUSTBASE -> bt, acc - | A.PARENTYPE (a1, d, a2) -> - let a1' = doAttributes a1 in - let a1n, a1f, a1t = partitionAttributes AttrType a1' in - let a2' = doAttributes a2 in - let a2n, a2f, a2t = partitionAttributes nameortype a2' in -(* - ignore (E.log "doType: %a @[a1n=%a@!a1f=%a@!a1t=%a@!a2n=%a@!a2f=%a@!a2t=%a@]@!" d_loc !currentLoc d_attrlist a1n d_attrlist a1f d_attrlist a1t d_attrlist a2n d_attrlist a2f d_attrlist a2t); -*) - let bt' = cabsTypeAddAttributes a1t bt in -(* - ignore (E.log "bt' = %a\n" d_type bt'); -*) - let bt'', a1fadded = - match unrollType bt with - TFun _ -> cabsTypeAddAttributes a1f bt', true - | _ -> bt', false - in - (* Now recurse *) - let restyp, nattr = doDeclType bt'' acc d in - (* Add some more type attributes *) - let restyp = cabsTypeAddAttributes a2t restyp in - (* See if we can add some more type attributes *) - let restyp' = - match unrollType restyp with - TFun _ -> - if a1fadded then - cabsTypeAddAttributes a2f restyp - else - cabsTypeAddAttributes a2f - (cabsTypeAddAttributes a1f restyp) - | TPtr ((TFun _ as tf), ap) when not !msvcMode -> - if a1fadded then - TPtr(cabsTypeAddAttributes a2f tf, ap) - else - TPtr(cabsTypeAddAttributes a2f - (cabsTypeAddAttributes a1f tf), ap) - | _ -> - if a1f <> [] && not a1fadded then - E.s (error "Invalid position for (prefix) function type attributes:%a" - d_attrlist a1f); - if a2f <> [] then - E.s (error "Invalid position for (post) function type attributes:%a" - d_attrlist a2f); - restyp - in -(* - ignore (E.log "restyp' = %a\n" d_type restyp'); -*) - (* Now add the name attributes and return *) - restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr) - - | A.PTR (al, d) -> - let al' = doAttributes al in - let an, af, at = partitionAttributes AttrType al' in - (* Now recurse *) - let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in - (* See if we can do anything with function type attributes *) - let restyp' = - match unrollType restyp with - TFun _ -> cabsTypeAddAttributes af restyp - | TPtr((TFun _ as tf), ap) -> - TPtr(cabsTypeAddAttributes af tf, ap) - | _ -> - if af <> [] then - E.s (error "Invalid position for function type attributes:%a" - d_attrlist af); - restyp - in - (* Now add the name attributes and return *) - restyp', cabsAddAttributes an nattr - - - | A.ARRAY (d, al, len) -> - let lo = - match len with - A.NOTHING -> None - | _ -> - let len' = doPureExp len in - let _, len'' = castTo (typeOf len') intType len' in - let elsz = - try (bitsSizeOf bt + 7) / 8 - with _ -> 1 (** We get this if we cannot compute the size of - * one element. This can happen, when we define - * an extern, for example. We use 1 for now *) - in - (match constFold true len' with - Const(CInt64(i, _, _)) -> - if i < 0L then - E.s (error "Length of array is negative\n"); - if Int64.mul i (Int64.of_int elsz) >= 0x80000000L then - E.s (error "Length of array is too large\n") - - - | l -> - if isConstant l then - (* e.g., there may be a float constant involved. - * We'll leave it to the user to ensure the length is - * non-negative, etc.*) - ignore(warn "Unable to do constant-folding on array length %a. Some CIL operations on this array may fail." - d_exp l) - else - E.s (error "Length of array is not a constant: %a\n" - d_exp l)); - Some len'' - in - let al' = doAttributes al in - doDeclType (TArray(bt, lo, al')) acc d - - | A.PROTO (d, args, isva) -> - (* Start a scope for the parameter names *) - enterScope (); - (* Intercept the old-style use of varargs.h. On GCC this means that - * we have ellipsis and a last argument "builtin_va_alist: - * builtin_va_alist_t". On MSVC we do not have the ellipsis and we - * have a last argument "va_alist: va_list" *) - let args', isva' = - if args != [] && !msvcMode = not isva then begin - let newisva = ref isva in - let rec doLast = function - [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))] - when isOldStyleVarArgTypeName atn && - isOldStyleVarArgName an -> begin - (* Turn it into a vararg *) - newisva := true; - (* And forget about this argument *) - [] - end - - | a :: rest -> a :: doLast rest - | [] -> [] - in - let args' = doLast args in - (args', !newisva) - end else (args, isva) - in - (* Make the argument as for a formal *) - let doOneArg (s, (n, ndt, a, cloc)) : varinfo = - let s' = doSpecList n s in - let ndt' = match isVariableSizedArray ndt with - None -> ndt - | Some (ndt', se, len) -> - (* If this is a variable-sized array, we replace the array - type with a pointer type. This is the defined behavior - for array parameters, so we do not need to add this to - varSizeArrays, fix sizeofs, etc. *) - if isNotEmpty se then - E.s (error "array parameter: length not pure"); - ndt' - in - let vi = makeVarInfoCabs ~isformal:true ~isglobal:false - (convLoc cloc) s' (n,ndt',a) in - (* Add the formal to the environment, so it can be referenced by - other formals (e.g. in an array type, although that will be - changed to a pointer later, or though typeof). *) - addLocalToEnv vi.vname (EnvVar vi); - vi - in - let targs : varinfo list option = - match List.map doOneArg args' with - | [] -> None (* No argument list *) - | [t] when isVoidType t.vtype -> - Some [] - | l -> Some l - in - exitScope (); - (* Turn [] types into pointers in the arguments and the result type. - * Turn function types into pointers to respective. This simplifies - * our life a lot, and is what the standard requires. *) - let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit = - match args with - [] -> () - | a :: args' -> - (match unrollType a.vtype with - TArray(t,_,attr) -> a.vtype <- TPtr(t, attr) - | TFun _ -> a.vtype <- TPtr(a.vtype, []) - | TComp (comp, _) -> begin - match isTransparentUnion a.vtype with - None -> () - | Some fstfield -> - transparentUnionArgs := - (argidx, a.vtype) :: !transparentUnionArgs; - a.vtype <- fstfield.ftype; - end - | _ -> ()); - fixupArgumentTypes (argidx + 1) args' - in - let args = - match targs with - None -> None - | Some argl -> - fixupArgumentTypes 0 argl; - Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl) - in - let tres = - match unrollType bt with - TArray(t,_,attr) -> TPtr(t, attr) - | _ -> bt - in - doDeclType (TFun (tres, args, isva', [])) acc d - - in - doDeclType bt [] dt - -(* If this is a declarator for a variable size array then turn it into a - pointer type and a length *) -and isVariableSizedArray (dt: A.decl_type) - : (A.decl_type * chunk * exp) option = - let res = ref None in - let rec findArray = function - ARRAY (JUSTBASE, al, lo) when lo != A.NOTHING -> - (* Try to compile the expression to a constant *) - let (se, e', _) = doExp true lo (AExp (Some intType)) in - if isNotEmpty se || not (isConstant e') then begin - res := Some (se, e'); - PTR (al, JUSTBASE) - end else - ARRAY (JUSTBASE, al, lo) - | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo) - | PTR (al, dt) -> PTR (al, findArray dt) - | JUSTBASE -> JUSTBASE - | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta) - | PROTO (dt, f, a) -> PROTO (findArray dt, f, a) - in - let dt' = findArray dt in - match !res with - None -> None - | Some (se, e) -> Some (dt', se, e) - -and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ = - let bt',sto,inl,attrs = doSpecList "" specs in - if sto <> NoStorage || inl then - E.s (error "Storage or inline specifier in type only"); - let tres, nattr = doType AttrType bt' (A.PARENTYPE(attrs, dt, [])) in - if nattr <> [] then - E.s (error "Name attributes in only_type: %a" - d_attrlist nattr); - tres - - -and makeCompType (isstruct: bool) - (n: string) - (nglist: A.field_group list) - (a: attribute list) = - (* Make a new name for the structure *) - let kind = if isstruct then "struct" else "union" in - let n', _ = newAlphaName true kind n in - (* Create the self cell for use in fields and forward references. Or maybe - * one exists already from a forward reference *) - let comp, _ = createCompInfo isstruct n' in - let doFieldGroup ((s: A.spec_elem list), - (nl: (A.name * A.expression option) list)) : 'a list = - (* Do the specifiers exactly once *) - let sugg = match nl with - [] -> "" - | ((n, _, _, _), _) :: _ -> n - in - let bt, sto, inl, attrs = doSpecList sugg s in - (* Do the fields *) - let makeFieldInfo - (((n,ndt,a,cloc) : A.name), (widtho : A.expression option)) - : fieldinfo = - if sto <> NoStorage || inl then - E.s (error "Storage or inline not allowed for fields"); - let ftype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in - (* check for fields whose type is an undefined struct. This rules - out circularity: - struct C1 { struct C2 c2; }; //This line is now an error. - struct C2 { struct C1 c1; int dummy; }; - *) - (match unrollType ftype with - TComp (ci',_) when not ci'.cdefined -> - E.s (error "Type of field %s is an undefined struct.\n" n) - | _ -> ()); - let width = - match widtho with - None -> None - | Some w -> begin - (match unrollType ftype with - TInt (ikind, a) -> () - | TEnum _ -> () - | _ -> E.s (error "Base type for bitfield is not an integer type")); - match isIntegerConstant w with - Some n -> Some n - | None -> E.s (error "bitfield width is not an integer constant") - end - in - (* If the field is unnamed and its type is a structure of union type - * then give it a distinguished name *) - let n' = - if n = missingFieldName then begin - match unrollType ftype with - TComp _ -> begin - incr annonCompFieldNameId; - annonCompFieldName ^ (string_of_int !annonCompFieldNameId) - end - | _ -> n - end else - n - in - { fcomp = comp; - fname = n'; - ftype = ftype; - fbitfield = width; - fattr = nattr; - floc = convLoc cloc - } - in - List.map makeFieldInfo nl - in - - - let flds = List.concat (List.map doFieldGroup nglist) in - if comp.cfields <> [] then begin - (* This appears to be a multiply defined structure. This can happen from - * a construct like "typedef struct foo { ... } A, B;". This is dangerous - * because at the time B is processed some forward references in { ... } - * appear as backward references, which coild lead to circularity in - * the type structure. We do a thourough check and then we reuse the type - * for A *) - let fieldsSig fs = List.map (fun f -> typeSig f.ftype) fs in - if not (Util.equals (fieldsSig comp.cfields) (fieldsSig flds)) then - ignore (error "%s seems to be multiply defined" (compFullName comp)) - end else - comp.cfields <- flds; - -(* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *) - comp.cattr <- a; - let res = TComp (comp, []) in - (* This compinfo is defined, even if there are no fields *) - comp.cdefined <- true; - (* Create a typedef for this one *) - cabsPushGlobal (GCompTag (comp, !currentLoc)); - - (* There must be a self cell created for this already *) - addLocalToEnv (kindPlusName kind n) (EnvTyp res); - (* Now create a typedef with just this type *) - res - -and preprocessCast (specs: A.specifier) - (dt: A.decl_type) - (ie: A.init_expression) - : A.specifier * A.decl_type * A.init_expression = - let typ = doOnlyType specs dt in - (* If we are casting to a union type then we have to treat this as a - * constructor expression. This is to handle the gcc extension that allows - * cast from a type of a field to the type of the union *) - let ie' = - match unrollType typ, ie with - TComp (c, _), A.SINGLE_INIT _ when not c.cstruct -> - A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", - A.NEXT_INIT), - ie)] - | _, _ -> ie - in - (* Maybe specs contains an unnamed composite. Replace with the name so that - * when we do again the specs we get the right name *) - let specs1 = - match typ with - TComp (ci, _) -> - List.map - (function - A.SpecType (A.Tstruct ("", flds, [])) -> - A.SpecType (A.Tstruct (ci.cname, None, [])) - | A.SpecType (A.Tunion ("", flds, [])) -> - A.SpecType (A.Tunion (ci.cname, None, [])) - | s -> s) specs - | _ -> specs - in - specs1, dt, ie' - -and getIntConstExp (aexp) : exp = - let c, e, _ = doExp true aexp (AExp None) in - if not (isEmpty c) then - E.s (error "Constant expression %a has effects" d_exp e); - match e with - (* first, filter for those Const exps that are integers *) - | Const (CInt64 _ ) -> e - | Const (CEnum _) -> e - | Const (CChr i) -> Const(charConstToInt i) - - (* other Const expressions are not ok *) - | Const _ -> E.s (error "Expected integer constant and got %a" d_exp e) - - (* now, anything else that 'doExp true' returned is ok (provided - that it didn't yield side effects); this includes, in particular, - the various sizeof and alignof expression kinds *) - | _ -> e - -(* this is like 'isIntConstExp', but retrieves the actual integer - * the expression denotes; I have not extended it to work with - * sizeof/alignof since (for CCured) we can't const-eval those, - * and it's not clear whether they can be bitfield width specifiers - * anyway (since that's where this function is used) *) -and isIntegerConstant (aexp) : int option = - match doExp true aexp (AExp None) with - (c, e, _) when isEmpty c -> begin - match isInteger e with - Some i64 -> Some (Int64.to_int i64) - | _ -> None - end - | _ -> None - - (* Process an expression and in the process do some type checking, - * extract the effects as separate statements *) -and doExp (asconst: bool) (* This expression is used as a constant *) - (e: A.expression) - (what: expAction) : (chunk * exp * typ) = - (* A subexpression of array type is automatically turned into StartOf(e). - * Similarly an expression of function type is turned into AddrOf. So - * essentially doExp should never return things of type TFun or TArray *) - let processArrayFun e t = - match e, unrollType t with - (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) -> - mkStartOfAndMark lv, TPtr(tbase, a) - | (Lval(lv) | CastE(_, Lval lv)), TFun _ -> - mkAddrOfAndMark lv, TPtr(t, []) - | _, (TArray _ | TFun _) -> - E.s (error "Array or function expression is not lval: %a@!" - d_plainexp e) - | _ -> e, t - in - (* Before we return we call finishExp *) - let finishExp ?(newWhat=what) - (se: chunk) (e: exp) (t: typ) : chunk * exp * typ = - match newWhat with - ADrop -> (se, e, t) - | AExpLeaveArrayFun -> - (se, e, t) (* It is important that we do not do "processArrayFun" in - * this case. We exploit this when we process the typeOf - * construct *) - | AExp _ -> - let (e', t') = processArrayFun e t in -(* - ignore (E.log "finishExp: e'=%a, t'=%a\n" - d_exp e' d_type t'); -*) - (se, e', t') - - | ASet (lv, lvt) -> begin - (* See if the set was done already *) - match e with - Lval(lv') when lv == lv' -> - (se, e, t) - | _ -> - let (e', t') = processArrayFun e t in - let (t'', e'') = castTo t' lvt e' in -(* - ignore (E.log "finishExp: e = %a\n e'' = %a\n" d_plainexp e d_plainexp e''); -*) - (se +++ (Set(lv, e'', !currentLoc)), e'', t'') - end - in - let rec findField (n: string) (fidlist: fieldinfo list) : offset = - (* Depth first search for the field. This appears to be what GCC does. - * MSVC checks that there are no ambiguous field names, so it does not - * matter how we search *) - let rec search = function - [] -> NoOffset (* Did not find *) - | fid :: rest when fid.fname = n -> Field(fid, NoOffset) - | fid :: rest when prefix annonCompFieldName fid.fname -> begin - match unrollType fid.ftype with - TComp (ci, _) -> - let off = search ci.cfields in - if off = NoOffset then - search rest (* Continue searching *) - else - Field (fid, off) - | _ -> E.s (bug "unnamed field type is not a struct/union") - end - | _ :: rest -> search rest - in - let off = search fidlist in - if off = NoOffset then - E.s (error "Cannot find field %s" n); - off - in - try - match e with - | A.NOTHING when what = ADrop -> finishExp empty (integer 0) intType - | A.NOTHING -> - let res = Const(CStr "exp_nothing") in - finishExp empty res (typeOf res) - - (* Do the potential lvalues first *) - | A.VARIABLE n -> begin - (* Look up in the environment *) - try - let envdata = H.find env n in - match envdata with - EnvVar vi, _ -> - (* if isconst && - not (isFunctionType vi.vtype) && - not (isArrayType vi.vtype)then - E.s (error "variable appears in constant"); *) - finishExp empty (Lval(var vi)) vi.vtype - | EnvEnum (tag, typ), _ -> - if !Cil.lowerConstants then - finishExp empty tag typ - else begin - let ei = - match unrollType typ with - TEnum(ei, _) -> ei - | _ -> assert false - in - finishExp empty (Const (CEnum(tag, n, ei))) typ - end - - | _ -> raise Not_found - with Not_found -> begin - if isOldStyleVarArgName n then - E.s (error "Cannot resolve variable %s. This could be a CIL bug due to the handling of old-style variable argument functions.\n" n) - else - E.s (error "Cannot resolve variable %s.\n" n) - end - end - | A.INDEX (e1, e2) -> begin - (* Recall that doExp turns arrays into StartOf pointers *) - let (se1, e1', t1) = doExp false e1 (AExp None) in - let (se2, e2', t2) = doExp false e2 (AExp None) in - let se = se1 @@ se2 in - let (e1'', t1, e2'', tresult) = - (* Either e1 or e2 can be the pointer *) - match unrollType t1, unrollType t2 with - TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e - | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e - | _ -> - E.s (error - "Expecting a pointer type in index:@! t1=%a@!t2=%a@!" - d_plaintype t1 d_plaintype t2) - in - (* We have to distinguish the construction based on the type of e1'' *) - let res = - match e1'' with - StartOf array -> (* A real array indexing operation *) - addOffsetLval (Index(e2'', NoOffset)) array - | _ -> (* Turn into *(e1 + e2) *) - mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset - in - (* Do some optimization of StartOf *) - finishExp se (Lval res) tresult - - end - | A.UNARY (A.MEMOF, e) -> - if asconst then - ignore (warn "MEMOF in constant"); - let (se, e', t) = doExp false e (AExp None) in - let tresult = - match unrollType t with - | TPtr(te, _) -> te - | _ -> E.s (error "Expecting a pointer type in *. Got %a@!" - d_plaintype t) - in - finishExp se - (Lval (mkMem e' NoOffset)) - tresult - - (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be - * + beoff + off(str)) *) - | A.MEMBEROF (e, str) -> - (* member of is actually allowed if we only take the address *) - (* if isconst then - E.s (error "MEMBEROF in constant"); *) - let (se, e', t') = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x - | CastE(_, Lval x) -> x - | _ -> E.s (error "Expected an lval in MEMBEROF (field %s)" str) - in - let field_offset = - match unrollType t' with - TComp (comp, _) -> findField str comp.cfields - | _ -> E.s (error "expecting a struct with field %s" str) - in - let lv' = Lval(addOffsetLval field_offset lv) in - let field_type = typeOf lv' in - finishExp se lv' field_type - - (* e->str = * (e + off(str)) *) - | A.MEMBEROFPTR (e, str) -> - if asconst then - ignore (warn "MEMBEROFPTR in constant"); - let (se, e', t') = doExp false e (AExp None) in - let pointedt = - match unrollType t' with - TPtr(t1, _) -> t1 - | TArray(t1,_,_) -> t1 - | _ -> E.s (error "expecting a pointer to a struct") - in - let field_offset = - match unrollType pointedt with - TComp (comp, _) -> findField str comp.cfields - | x -> - E.s (error - "expecting a struct with field %s. Found %a. t1 is %a" - str d_type x d_type t') - in - let lv' = Lval (mkMem e' field_offset) in - let field_type = typeOf lv' in - finishExp se lv' field_type - - | A.CONSTANT ct -> begin - let hasSuffix str = - let l = String.length str in - fun s -> - let ls = String.length s in - l >= ls && s = String.uppercase (String.sub str (l - ls) ls) - in - match ct with - A.CONST_INT str -> begin - let res = parseInt str in - finishExp empty res (typeOf res) - end - -(* - | A.CONST_WSTRING wstr -> - let len = List.length wstr in - let wchar_t = !wcharType in - (* We will make an array big enough to contain the wide - * characters and the wide-null terminator *) - let ws_t = TArray(wchar_t, Some (integer len), []) in - let ws = - makeGlobalVar ("wide_string" ^ string_of_int !lastStructId) - ws_t - in - ws.vstorage <- Static; - incr lastStructId; - (* Make the initializer. Idx is a wide_char index. *) - let rec loop (idx: int) (s: int64 list) = - match s with - [] -> [] - | wc::rest -> - let wc_cilexp = Const (CInt64(wc, IInt, None)) in - (Index(integer idx, NoOffset), - SingleInit (mkCast wc_cilexp wchar_t)) - :: loop (idx + 1) rest - in - (* Add the definition for the array *) - cabsPushGlobal (GVar(ws, - {init = Some (CompoundInit(ws_t, - loop 0 wstr))}, - !currentLoc)); - finishExp empty (StartOf(Var ws, NoOffset)) - (TPtr(wchar_t, [])) - *) - - | A.CONST_WSTRING (ws: int64 list) -> - let res = Const(CWStr ((* intlist_to_wstring *) ws)) in - finishExp empty res (typeOf res) - - | A.CONST_STRING s -> - (* Maybe we burried __FUNCTION__ in there *) - let s' = - try - let start = String.index s (Char.chr 0) in - let l = String.length s in - let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in - let past = start + String.length tofind in - if past <= l && - String.sub s start (String.length tofind) = tofind then - (if start > 0 then String.sub s 0 start else "") ^ - !currentFunctionFDEC.svar.vname ^ - (if past < l then String.sub s past (l - past) else "") - else - s - with Not_found -> s - in - let res = Const(CStr s') in - finishExp empty res (typeOf res) - - | A.CONST_CHAR char_list -> - let a, b = (interpret_character_constant char_list) in - finishExp empty (Const a) b - - | A.CONST_WCHAR char_list -> - (* matth: I can't see a reason for a list of more than one char - * here, since the kinteger64 below will take only the lower 16 - * bits of value. ('abc' makes sense, because CHAR constants have - * type int, and so more than one char may be needed to represent - * the value. But L'abc' has type wchar, and so is equivalent to - * L'c'). But gcc allows L'abc', so I'll leave this here in case - * I'm missing some architecture dependent behavior. *) - let value = reduce_multichar !wcharType char_list in - let result = kinteger64 !wcharKind value in - finishExp empty result (typeOf result) - - | A.CONST_FLOAT str -> begin - (* Maybe it ends in U or UL. Strip those *) - let l = String.length str in - let hasSuffix = hasSuffix str in - let baseint, kind = - if hasSuffix "L" then - String.sub str 0 (l - 1), FLongDouble - else if hasSuffix "F" then - String.sub str 0 (l - 1), FFloat - else if hasSuffix "D" then - String.sub str 0 (l - 1), FDouble - else - str, FDouble - in - try - finishExp empty - (Const(CReal(float_of_string baseint, kind, - Some str))) - (TFloat(kind,[])) - with e -> begin - ignore (E.log "float_of_string %s (%s)\n" str - (Printexc.to_string e)); - let res = Const(CStr "booo CONS_FLOAT") in - finishExp empty res (typeOf res) - end - end - end - - | A.TYPE_SIZEOF (bt, dt) -> - let typ = doOnlyType bt dt in - finishExp empty (SizeOf(typ)) !typeOfSizeOf - - (* Intercept the sizeof("string") *) - | A.EXPR_SIZEOF (A.CONSTANT (A.CONST_STRING s)) -> begin - (* Process the string first *) - match doExp asconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with - _, Const(CStr s), _ -> - finishExp empty (SizeOfStr s) !typeOfSizeOf - | _ -> E.s (bug "cabs2cil: sizeOfStr") - end - - | A.EXPR_SIZEOF e -> - (* Allow non-constants in sizeof *) - (* Do not convert arrays and functions into pointers. *) - let (se, e', t) = doExp false e AExpLeaveArrayFun in -(* - ignore (E.log "sizeof: %a e'=%a, t=%a\n" - d_loc !currentLoc d_plainexp e' d_type t); -*) - (* !!!! The book says that the expression is not evaluated, so we - * drop the potential side-effects - if isNotEmpty se then - ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF\n"); -*) - let size = - match e' with (* If we are taking the sizeof an - * array we must drop the StartOf *) - StartOf(lv) -> SizeOfE (Lval(lv)) - - (* Maybe we are taking the sizeof for a CStr. In that case we - * mean the pointer to the start of the string *) - | Const(CStr _) -> SizeOf (charPtrType) - - (* Maybe we are taking the sizeof a variable-sized array *) - | Lval (Var vi, NoOffset) -> begin - try - IH.find varSizeArrays vi.vid - with Not_found -> SizeOfE e' - end - | _ -> SizeOfE e' - in - finishExp empty size !typeOfSizeOf - - | A.TYPE_ALIGNOF (bt, dt) -> - let typ = doOnlyType bt dt in - finishExp empty (AlignOf(typ)) !typeOfSizeOf - - | A.EXPR_ALIGNOF e -> - let (se, e', t) = doExp false e AExpLeaveArrayFun in - (* !!!! The book says that the expression is not evaluated, so we - * drop the potential side-effects - if isNotEmpty se then - ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF\n"); -*) - let e'' = - match e' with (* If we are taking the alignof an - * array we must drop the StartOf *) - StartOf(lv) -> Lval(lv) - - | _ -> e' - in - finishExp empty (AlignOfE(e'')) !typeOfSizeOf - - | A.CAST ((specs, dt), ie) -> - let s', dt', ie' = preprocessCast specs dt ie in - (* We know now that we can do s' and dt' many times *) - let typ = doOnlyType s' dt' in - let what' = - match what with - AExp (Some _) -> AExp (Some typ) - | AExp None -> what - | ADrop | AExpLeaveArrayFun -> what - | ASet (lv, lvt) -> - (* If the cast from typ to lvt would be dropped, then we - * continue with a Set *) - if false && Util.equals (typeSig typ) (typeSig lvt) then - what - else - AExp None (* We'll create a temporary *) - in - (* Remember here if we have done the Set *) - let (se, e', t'), (needcast: bool) = - match ie' with - A.SINGLE_INIT e -> doExp asconst e what', true - - | A.NO_INIT -> E.s (error "missing expression in cast") - - | A.COMPOUND_INIT _ -> begin - (* Pretend that we are declaring and initializing a brand new - * variable *) - let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in - incr constrExprId; - let spec_res = doSpecList "" s' in - let se1 = - if !scopes == [] then begin - ignore (createGlobal spec_res - ((newvar, dt', [], cabslu), ie')); - empty - end else - createLocal spec_res ((newvar, dt', [], cabslu), ie') - in - (* Now pretend that e is just a reference to the newly created - * variable *) - let se, e', t' = doExp asconst (A.VARIABLE newvar) what' in - (* If typ is an array then the doExp above has already added a - * StartOf. We must undo that now so that it is done once by - * the finishExp at the end of this case *) - let e2, t2 = - match unrollType typ, e' with - TArray _, StartOf lv -> Lval lv, typ - | _, _ -> e', t' - in - (* If we are here, then the type t2 is guaranteed to match the - * type of the expression e2, so we do not need a cast. We have - * to worry about this because otherwise, we might need to cast - * between arrays or structures. *) - (se1 @@ se, e2, t2), false - end - in - let (t'', e'') = - match typ with - TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *) - | _ -> - (* Do this to check the cast, unless we are sure that we do not - * need the check. *) - let newtyp, newexp = - if needcast then - castTo ~fromsource:true t' typ e' - else - t', e' - in - newtyp, newexp - in - finishExp se e'' t'' - - | A.UNARY(A.MINUS, e) -> - let (se, e', t) = doExp asconst e (AExp None) in - if isIntegralType t then - let tres = integralPromotion t in - let e'' = - match e' with - | Const(CInt64(i, ik, _)) -> kinteger64 ik (Int64.neg i) - | _ -> UnOp(Neg, mkCastT e' t tres, tres) - in - finishExp se e'' tres - else - if isArithmeticType t then - finishExp se (UnOp(Neg,e',t)) t - else - E.s (error "Unary - on a non-arithmetic type") - - | A.UNARY(A.BNOT, e) -> - let (se, e', t) = doExp asconst e (AExp None) in - if isIntegralType t then - let tres = integralPromotion t in - let e'' = UnOp(BNot, mkCastT e' t tres, tres) in - finishExp se e'' tres - else - E.s (error "Unary ~ on a non-integral type") - - | A.UNARY(A.PLUS, e) -> doExp asconst e what - - - | A.UNARY(A.ADDROF, e) -> begin - match e with - A.COMMA el -> (* GCC extension *) - doExp false - (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e)))) - what - | A.QUESTION (e1, e2, e3) -> (* GCC extension *) - doExp false - (A.QUESTION (e1, A.UNARY(A.ADDROF, e2), A.UNARY(A.ADDROF, e3))) - what - | A.VARIABLE s when - isOldStyleVarArgName s - && (match !currentFunctionFDEC.svar.vtype with - TFun(_, _, true, _) -> true | _ -> false) -> - (* We are in an old-style variable argument function and we are - * taking the address of the argument that was removed while - * processing the function type. We compute the address based on - * the address of the last real argument *) - if !msvcMode then begin - let rec getLast = function - [] -> E.s (unimp "old-style variable argument function without real arguments") - | [a] -> a - | _ :: rest -> getLast rest - in - let last = getLast !currentFunctionFDEC.sformals in - let res = mkAddrOfAndMark (var last) in - let tres = typeOf res in - let tres', res' = castTo tres (TInt(IULong, [])) res in - (* Now we must add to this address to point to the next - * argument. Round up to a multiple of 4 *) - let sizeOfLast = - (((bitsSizeOf last.vtype) + 31) / 32) * 4 - in - let res'' = - BinOp(PlusA, res', kinteger IULong sizeOfLast, tres') - in - finishExp empty res'' tres' - end else begin (* On GCC the only reliable way to do this is to - * call builtin_next_arg. If we take the address of - * a local we are going to get the address of a copy - * of the local ! *) - - doExp asconst - (A.CALL (A.VARIABLE "__builtin_next_arg", - [A.CONSTANT (A.CONST_INT "0")])) - what - end - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST (_, A.COMPOUND_INIT _)) -> begin - let (se, e', t) = doExp false e (AExp None) in - (* ignore (E.log "ADDROF on %a : %a\n" d_plainexp e' - d_plaintype t); *) - match e' with - ( Lval x | CastE(_, Lval x)) -> - finishExp se (mkAddrOfAndMark x) (TPtr(t, [])) - - | StartOf (lv) -> - let tres = TPtr(typeOfLval lv, []) in (* pointer to array *) - finishExp se (mkAddrOfAndMark lv) tres - - (* Function names are converted into pointers to the function. - * Taking the address-of again does not change things *) - | AddrOf (Var v, NoOffset) when isFunctionType v.vtype -> - finishExp se e' t - - | _ -> E.s (error "Expected lval for ADDROF. Got %a@!" - d_plainexp e') - end - | _ -> E.s (error "Unexpected operand for addrof") - end - | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin - match e with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.UNARY(uop, e)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.UNARY(uop, e2q), - A.UNARY(uop, e3q))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST _ (* A GCC extension *)) -> begin - let uop' = if uop = A.PREINCR then PlusA else MinusA in - if asconst then - ignore (warn "PREINCR or PREDECR in constant"); - let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x - | CastE (_, Lval x) -> x (* A GCC extension. The operation is - * done at the cast type. The result - * is also of the cast type *) - | _ -> E.s (error "Expected lval for ++ or --") - in - let tresult, result = doBinOp uop' e' t one intType in - finishExp (se +++ (Set(lv, mkCastT result tresult t, - !currentLoc))) - e' - tresult (* Should this be t instead ??? *) - end - | _ -> E.s (error "Unexpected operand for prefix -- or ++") - end - - | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin - match e with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.UNARY(uop, e)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST _ (* A GCC extension *) ) -> begin - if asconst then - ignore (warn "POSTINCR or POSTDECR in constant"); - (* If we do not drop the result then we must save the value *) - let uop' = if uop = A.POSINCR then PlusA else MinusA in - let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with - Lval x -> x - | CastE (_, Lval x) -> x (* GCC extension. The addition must - * be be done at the cast type. The - * result of this is also of the cast - * type *) - | _ -> E.s (error "Expected lval for ++ or --") - in - let tresult, opresult = doBinOp uop' e' t one intType in - let se', result = - if what <> ADrop then - let tmp = newTempVar t in - se +++ (Set(var tmp, e', !currentLoc)), Lval(var tmp) - else - se, e' - in - finishExp - (se' +++ (Set(lv, mkCastT opresult tresult t, - !currentLoc))) - result - tresult (* Should this be t instead ??? *) - end - | _ -> E.s (error "Unexpected operand for suffix ++ or --") - end - - | A.BINARY(A.ASSIGN, e1, e2) -> begin - match e1 with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.BINARY(A.ASSIGN, e, e2)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2), - A.BINARY(A.ASSIGN, e3q, e2))) - what - | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *) - doExp asconst - (A.CAST (t, - A.SINGLE_INIT (A.BINARY(A.ASSIGN, e, - A.CAST (t, A.SINGLE_INIT e2))))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ ) -> begin - if asconst then ignore (warn "ASSIGN in constant"); - let (se1, e1', lvt) = doExp false e1 (AExp None) in - let lv = - match e1' with - Lval x -> x - | _ -> E.s (error "Expected lval for assignment. Got %a\n" - d_plainexp e1') - in - let (se2, e'', t'') = doExp false e2 (ASet(lv, lvt)) in - finishExp (se1 @@ se2) e1' lvt - end - | _ -> E.s (error "Invalid left operand for ASSIGN") - end - - | A.BINARY((A.ADD|A.SUB|A.MUL|A.DIV|A.MOD|A.BAND|A.BOR|A.XOR| - A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) -> - let bop' = convBinOp bop in - let (se1, e1', t1) = doExp asconst e1 (AExp None) in - let (se2, e2', t2) = doExp asconst e2 (AExp None) in - let tresult, result = doBinOp bop' e1' t1 e2' t2 in - finishExp (se1 @@ se2) result tresult - - (* assignment operators *) - | A.BINARY((A.ADD_ASSIGN|A.SUB_ASSIGN|A.MUL_ASSIGN|A.DIV_ASSIGN| - A.MOD_ASSIGN|A.BAND_ASSIGN|A.BOR_ASSIGN|A.SHL_ASSIGN| - A.SHR_ASSIGN|A.XOR_ASSIGN) as bop, e1, e2) -> begin - match e1 with - A.COMMA el -> (* GCC extension *) - doExp asconst - (A.COMMA (replaceLastInList el - (fun e -> A.BINARY(bop, e, e2)))) - what - | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) - doExp asconst - (A.QUESTION (e1, A.BINARY(bop, e2q, e2), - A.BINARY(bop, e3q, e2))) - what - - | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) - A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | - A.CAST _ (* GCC extension *) ) -> begin - if asconst then - ignore (warn "op_ASSIGN in constant"); - let bop' = match bop with - A.ADD_ASSIGN -> PlusA - | A.SUB_ASSIGN -> MinusA - | A.MUL_ASSIGN -> Mult - | A.DIV_ASSIGN -> Div - | A.MOD_ASSIGN -> Mod - | A.BAND_ASSIGN -> BAnd - | A.BOR_ASSIGN -> BOr - | A.XOR_ASSIGN -> BXor - | A.SHL_ASSIGN -> Shiftlt - | A.SHR_ASSIGN -> Shiftrt - | _ -> E.s (error "binary +=") - in - let (se1, e1', t1) = doExp false e1 (AExp None) in - let lv1 = - match e1' with - Lval x -> x - | CastE (_, Lval x) -> x (* GCC extension. The operation and - * the result are at the cast type *) - | _ -> E.s (error "Expected lval for assignment with arith") - in - let (se2, e2', t2) = doExp false e2 (AExp None) in - let tresult, result = doBinOp bop' e1' t1 e2' t2 in - (* We must cast the result to the type of the lv1, which may be - * different than t1 if lv1 was a Cast *) - let _, result' = castTo tresult (typeOfLval lv1) result in - (* The type of the result is the type of the left-hand side *) - finishExp (se1 @@ se2 +++ - (Set(lv1, result', !currentLoc))) - e1' - t1 - end - | _ -> E.s (error "Unexpected left operand for assignment with arith") - end - - - | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin - let ce = doCondExp asconst e in - (* We must normalize the result to 0 or 1 *) - match ce with - CEExp (se, ((Const _) as c)) -> - finishExp se (if isConstTrue c then one else zero) intType - | CEExp (se, (UnOp(LNot, _, _) as e)) -> - (* already normalized to 0 or 1 *) - finishExp se e intType - | CEExp (se, e) -> - let e' = - let te = typeOf e in - let _, zte = castTo intType te zero in - BinOp(Ne, e, zte, te) - in - finishExp se e' intType - | _ -> - let tmp = var (newTempVar intType) in - finishExp (compileCondExp ce - (empty +++ (Set(tmp, integer 1, - !currentLoc))) - (empty +++ (Set(tmp, integer 0, - !currentLoc)))) - (Lval tmp) - intType - end - - | A.CALL(f, args) -> - if asconst then - ignore (warn "CALL in constant"); - let (sf, f', ft') = - match f with (* Treat the VARIABLE case separate - * becase we might be calling a - * function that does not have a - * prototype. In that case assume it - * takes INTs as arguments *) - A.VARIABLE n -> begin - try - let vi, _ = lookupVar n in - (empty, Lval(var vi), vi.vtype) (* Found. Do not use - * finishExp. Simulate what = - * AExp None *) - with Not_found -> begin - ignore (warnOpt "Calling function %s without prototype." n); - let ftype = TFun(intType, None, false, - [Attr("missingproto",[])]) in - (* Add a prototype to the environment *) - let proto, _ = - makeGlobalVarinfo false (makeGlobalVar n ftype) in - (* Make it EXTERN *) - proto.vstorage <- Extern; - IH.add noProtoFunctions proto.vid true; - (* Add it to the file as well *) - cabsPushGlobal (GVarDecl (proto, !currentLoc)); - (empty, Lval(var proto), ftype) - end - end - | _ -> doExp false f (AExp None) - in - (* Get the result type and the argument types *) - let (resType, argTypes, isvar, f'') = - match unrollType ft' with - TFun(rt,at,isvar,a) -> (rt,at,isvar,f') - | TPtr (t, _) -> begin - match unrollType t with - TFun(rt,at,isvar,a) -> (* Make the function pointer - * explicit *) - let f'' = - match f' with - AddrOf lv -> Lval(lv) - | _ -> Lval(mkMem f' NoOffset) - in - (rt,at,isvar, f'') - | x -> - E.s (error "Unexpected type of the called function %a: %a" - d_exp f' d_type x) - end - | x -> E.s (error "Unexpected type of the called function %a: %a" - d_exp f' d_type x) - in - let argTypesList = argsToList argTypes in - (* Drop certain qualifiers from the result type *) - let resType' = resType in - (* Before we do the arguments we try to intercept a few builtins. For - * these we have defined then with a different type, so we do not - * want to give warnings. We'll just leave the arguments of these - * functions alone*) - let isSpecialBuiltin = - match f'' with - Lval (Var fv, NoOffset) -> - fv.vname = "__builtin_stdarg_start" || - fv.vname = "__builtin_va_arg" || - fv.vname = "__builtin_va_start" || - fv.vname = "__builtin_expect" || - fv.vname = "__builtin_next_arg" - | _ -> false - in - - (** If the "--forceRLArgEval" flag was used, make sure - we evaluate args right-to-left. - Added by Nathan Cooprider. **) - let force_right_to_left_evaluation (c, e, t) = - (* If chunk is empty then it is not already evaluated *) - (* constants don't need to be pulled out *) - if (!forceRLArgEval && (not (isConstant e)) && - (not isSpecialBuiltin)) then - (* create a temporary *) - let tmp = newTempVar t in - (* create an instruction to give the e to the temporary *) - let i = Set(var tmp, e, !currentLoc) in - (* add the instruction to the chunk *) - (* change the expression to be the temporary *) - (c +++ i, (Lval(var tmp)), t) - else - (c, e, t) - in - (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *) - let rec loopArgs - : (string * typ * attributes) list * A.expression list - -> (chunk * exp list) = function - | ([], []) -> (empty, []) - - | args, [] -> - if not isSpecialBuiltin then - ignore (warnOpt - "Too few arguments in call to %a." - d_exp f'); - (empty, []) - - | ((_, at, _) :: atypes, a :: args) -> - let (ss, args') = loopArgs (atypes, args) in - (* Do not cast as part of translating the argument. We let - * the castTo to do this work. This was necessary for - * test/small1/union5, in which a transparent union is passed - * as an argument *) - let (sa, a', att) = force_right_to_left_evaluation - (doExp false a (AExp None)) in - let (_, a'') = castTo att at a' in - (ss @@ sa, a'' :: args') - - | ([], args) -> (* No more types *) - if not isvar && argTypes != None && not isSpecialBuiltin then - (* Do not give a warning for functions without a prototype*) - ignore (warnOpt "Too many arguments in call to %a" d_exp f'); - let rec loop = function - [] -> (empty, []) - | a :: args -> - let (ss, args') = loop args in - let (sa, a', at) = force_right_to_left_evaluation - (doExp false a (AExp None)) in - (ss @@ sa, a' :: args') - in - loop args - in - let (sargs, args') = loopArgs (argTypesList, args) in - (* Setup some pointer to the elements of the call. We may change - * these below *) - let prechunk: chunk ref = ref (sf @@ sargs) in (* comes before *) - - (* Do we actually have a call, or an expression? *) - let piscall: bool ref = ref true in - - let pf: exp ref = ref f'' in (* function to call *) - let pargs: exp list ref = ref args' in (* arguments *) - let pis__builtin_va_arg: bool ref = ref false in - let pwhat: expAction ref = ref what in (* what to do with result *) - - let pres: exp ref = ref zero in (* If we do not have a call, this is - * the result *) - let prestype: typ ref = ref intType in - - let rec dropCasts = function CastE (_, e) -> dropCasts e | e -> e in - (* Get the name of the last formal *) - let getNameLastFormal () : string = - match !currentFunctionFDEC.svar.vtype with - TFun(_, Some args, true, _) -> begin - match List.rev args with - (last_par_name, _, _) :: _ -> last_par_name - | _ -> "" - end - | _ -> "" - in - - (* Try to intercept some builtins *) - (match !pf with - Lval(Var fv, NoOffset) -> begin - if fv.vname = "__builtin_va_arg" then begin - match !pargs with - marker :: SizeOf resTyp :: _ -> begin - (* Make a variable of the desired type *) - let destlv, destlvtyp = - match !pwhat with - ASet (lv, lvt) -> lv, lvt - | _ -> var (newTempVar resTyp), resTyp - in - pwhat := (ASet (destlv, destlvtyp)); - pargs := [marker; SizeOf resTyp; AddrOf destlv]; - pis__builtin_va_arg := true; - end - | _ -> - ignore (warn "Invalid call to %s\n" fv.vname); - end else if fv.vname = "__builtin_stdarg_start" then begin - match !pargs with - marker :: last :: [] -> begin - let isOk = - match dropCasts last with - Lval (Var lastv, NoOffset) -> - lastv.vname = getNameLastFormal () - | _ -> false - in - if not isOk then - ignore (warn "The second argument in call to %s should be the last formal argument\n" fv.vname); - - (* Check that "lastv" is indeed the last variable in the - * prototype and then drop it *) - pargs := [ marker ] - end - | _ -> - ignore (warn "Invalid call to %s\n" fv.vname); - - (* We have to turn uses of __builtin_varargs_start into uses - * of __builtin_stdarg_start (because we have dropped the - * __builtin_va_alist argument from this function) *) - - end else if fv.vname = "__builtin_varargs_start" then begin - (* Lookup the prototype for the replacement *) - let v, _ = - try lookupGlobalVar "__builtin_stdarg_start" - with Not_found -> E.s (bug "Cannot find __builtin_stdarg_start to replace %s\n" fv.vname) - in - pf := Lval (var v) - end else if fv.vname = "__builtin_next_arg" then begin - match !pargs with - last :: [] -> begin - let isOk = - match dropCasts last with - Lval (Var lastv, NoOffset) -> - lastv.vname = getNameLastFormal () - | _ -> false - in - if not isOk then - ignore (warn "The argument in call to %s should be the last formal argument\n" fv.vname); - - pargs := [ ] - end - | _ -> - ignore (warn "Invalid call to %s\n" fv.vname); - end else if fv.vname = "__builtin_constant_p" then begin - (* Drop the side-effects *) - prechunk := empty; - - (* Constant-fold the argument and see if it is a constant *) - (match !pargs with - [ arg ] -> begin - match constFold true arg with - Const _ -> piscall := false; - pres := integer 1; - prestype := intType - - | _ -> piscall := false; - pres := integer 0; - prestype := intType - end - | _ -> - ignore (warn "Invalid call to builtin_constant_p")); - end - end - | _ -> ()); - - - (* Now we must finish the call *) - if !piscall then begin - let addCall (calldest: lval option) (res: exp) (t: typ) = - prechunk := !prechunk +++ - (Call(calldest, !pf, !pargs, !currentLoc)); - pres := res; - prestype := t - in - match !pwhat with - ADrop -> addCall None zero intType - - (* Set to a variable of corresponding type *) - | ASet(lv, vtype) -> - (* Make an exception here for __builtin_va_arg *) - if !pis__builtin_va_arg then - addCall None (Lval(lv)) vtype - else - addCall (Some lv) (Lval(lv)) vtype - - | _ -> begin - let tmp, restyp' = - match !pwhat with - AExp (Some t) -> newTempVar t, t - | _ -> newTempVar resType', resType' - in - (* Remember that this variable has been created for this - * specific call. We will use this in collapseCallCast and - * above in finishCall. *) - IH.add callTempVars tmp.vid (); - addCall (Some (var tmp)) (Lval(var tmp)) restyp' - end - end; - - finishExp !prechunk !pres !prestype - - - | A.COMMA el -> - if asconst then - ignore (warn "COMMA in constant"); - let rec loop sofar = function - [e] -> - let (se, e', t') = doExp false e what in (* Pass on the action *) - (sofar @@ se, e', t') -(* - finishExp (sofar @@ se) e' t' (* does not hurt to do it twice. - * GN: it seems it does *) -*) - | e :: rest -> - let (se, _, _) = doExp false e ADrop in - loop (sofar @@ se) rest - | [] -> E.s (error "empty COMMA expression") - in - loop empty el - - | A.QUESTION (e1,e2,e3) when what = ADrop -> - if asconst then - ignore (warn "QUESTION with ADrop in constant"); - let (se3,_,_) = doExp false e3 ADrop in - let se2 = - match e2 with - A.NOTHING -> skipChunk - | _ -> let (se2,_,_) = doExp false e2 ADrop in se2 - in - finishExp (doCondition asconst e1 se2 se3) zero intType - - | A.QUESTION (e1, e2, e3) -> begin (* what is not ADrop *) - (* Compile the conditional expression *) - let ce1 = doCondExp asconst e1 in - (* Now we must find the type of both branches, in order to compute - * the type of the result *) - let se2, e2'o (* is an option. None means use e1 *), t2 = - match e2 with - A.NOTHING -> begin (* The same as the type of e1 *) - match ce1 with - CEExp (_, e1') -> empty, None, typeOf e1' (* Do not promote - to bool *) - | _ -> empty, None, intType - end - | _ -> - let se2, e2', t2 = doExp asconst e2 (AExp None) in - se2, Some e2', t2 - in - (* Do e3 for real *) - let se3, e3', t3 = doExp asconst e3 (AExp None) in - (* Compute the type of the result *) - let tresult = conditionalConversion t2 t3 in - match ce1 with - CEExp (se1, e1') when isConstFalse e1' && canDrop se2 -> - finishExp (se1 @@ se3) (snd (castTo t3 tresult e3')) tresult - | CEExp (se1, e1') when isConstTrue e1' && canDrop se3 -> - begin - match e2'o with - None -> (* use e1' *) - finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult - | Some e2' -> - finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult - end - - | _ -> (* Use a conditional *) begin - match e2 with - A.NOTHING -> - let tmp = var (newTempVar tresult) in - let (se1, _, _) = doExp asconst e1 (ASet(tmp, tresult)) in - let (se3, _, _) = doExp asconst e3 (ASet(tmp, tresult)) in - finishExp (se1 @@ ifChunk (Lval(tmp)) lu - skipChunk se3) - (Lval(tmp)) - tresult - | _ -> - let lv, lvt = - match what with - | ASet (lv, lvt) -> lv, lvt - | _ -> - let tmp = newTempVar tresult in - var tmp, tresult - in - (* Now do e2 and e3 for real *) - let (se2, _, _) = doExp asconst e2 (ASet(lv, lvt)) in - let (se3, _, _) = doExp asconst e3 (ASet(lv, lvt)) in - finishExp (doCondition asconst e1 se2 se3) (Lval(lv)) tresult - end - -(* - (* Do these only to collect the types *) - let se2, e2', t2' = - match e2 with - A.NOTHING -> (* A GNU thing. Use e1 as e2 *) - doExp isconst e1 (AExp None) - | _ -> doExp isconst e2 (AExp None) in - (* Do e3 for real *) - let se3, e3', t3' = doExp isconst e3 (AExp None) in - (* Compute the type of the result *) - let tresult = conditionalConversion e2' t2' e3' t3' in - if (isEmpty se2 || e2 = A.NOTHING) - && isEmpty se3 && isconst then begin - (* Use the Question. This allows Question in initializers without - * having to do constant folding *) - let se1, e1', t1 = doExp isconst e1 (AExp None) in - ignore (checkBool t1 e1'); - let e2'' = - if e2 = A.NOTHING then - mkCastT e1' t1 tresult - else mkCastT e2' t2' tresult (* We know se2 is empty *) - in - let e3'' = mkCastT e3' t3' tresult in - let resexp = - match e1' with - Const(CInt64(i, _, _)) when i <> Int64.zero -> e2'' - | Const(CInt64(z, _, _)) when z = Int64.zero -> e3'' - | _ -> Question(e1', e2'', e3'') - in - finishExp se1 resexp tresult - end else begin (* Now use a conditional *) - match e2 with - A.NOTHING -> - let tmp = var (newTempVar tresult) in - let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in - let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in - finishExp (se1 @@ ifChunk (Lval(tmp)) lu - skipChunk se3) - (Lval(tmp)) - tresult - | _ -> - let lv, lvt = - match what with - | ASet (lv, lvt) -> lv, lvt - | _ -> - let tmp = newTempVar tresult in - var tmp, tresult - in - (* Now do e2 and e3 for real *) - let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in - let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in - finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult - end -*) - end - - | A.GNU_BODY b -> begin - (* Find the last A.COMPUTATION and remember it. This one is invoked - * on the reversed list of statements. *) - let rec findLastComputation = function - s :: _ -> - let rec findLast = function - A.SEQUENCE (_, s, loc) -> findLast s - | CASE (_, s, _) -> findLast s - | CASERANGE (_, _, s, _) -> findLast s - | LABEL (_, s, _) -> findLast s - | (A.COMPUTATION _) as s -> s - | _ -> raise Not_found - in - findLast s - | [] -> raise Not_found - in - (* Save the previous data *) - let old_gnu = ! gnu_body_result in - let lastComp, isvoidbody = - match what with - ADrop -> (* We are dropping the result *) - A.NOP cabslu, true - | _ -> - try findLastComputation (List.rev b.A.bstmts), false - with Not_found -> - E.s (error "Cannot find COMPUTATION in GNU.body") - (* A.NOP cabslu, true *) - in - (* Prepare some data to be filled by doExp *) - let data : (exp * typ) option ref = ref None in - gnu_body_result := (lastComp, data); - - let se = doBody b in - - gnu_body_result := old_gnu; - match !data with - None when isvoidbody -> finishExp se zero voidType - | None -> E.s (bug "Cannot find COMPUTATION in GNU.body") - | Some (e, t) -> finishExp se e t - end - - | A.LABELADDR l -> begin (* GCC's taking the address of a label *) - let l = lookupLabel l in (* To support locallly declared labels *) - let addrval = - try H.find gotoTargetHash l - with Not_found -> begin - let res = !gotoTargetNextAddr in - incr gotoTargetNextAddr; - H.add gotoTargetHash l res; - res - end - in - finishExp empty (mkCast (integer addrval) voidPtrType) voidPtrType - end - - | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input") - - with e -> begin - ignore (E.log "error in doExp (%s)@!" (Printexc.to_string e)); - E.hadErrors := true; - (i2c (dInstr (dprintf "booo_exp(%t)" d_thisloc) !currentLoc), - integer 0, intType) - end - -(* bop is always the arithmetic version. Change it to the appropriate pointer - * version if necessary *) -and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp = - let doArithmetic () = - let tres = arithmeticConversion t1 t2 in - (* Keep the operator since it is arithmetic *) - tres, - optConstFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres - in - let doArithmeticComp () = - let tres = arithmeticConversion t1 t2 in - (* Keep the operator since it is arithemtic *) - intType, - optConstFoldBinOp false bop - (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) intType - in - let doIntegralArithmetic () = - let tres = unrollType (arithmeticConversion t1 t2) in - match tres with - TInt _ -> - tres, - optConstFoldBinOp false bop - (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres - | _ -> E.s (error "%a operator on a non-integer type" d_binop bop) - in - let pointerComparison e1 t1 e2 t2 = - (* XL: Do not cast both sides -- what's the point? *) - intType, - optConstFoldBinOp false bop e1 e2 intType - in - - match bop with - (Mult|Div) -> doArithmetic () - | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic () - | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result - * has the same type as the left hand side *) - if !msvcMode then - (* MSVC has a bug. We duplicate it here *) - doIntegralArithmetic () - else - let t1' = integralPromotion t1 in - let t2' = integralPromotion t2 in - t1', - optConstFoldBinOp false bop (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1' - - | (PlusA|MinusA) - when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic () - | (Eq|Ne|Lt|Le|Ge|Gt) - when isArithmeticType t1 && isArithmeticType t2 -> - doArithmeticComp () - | PlusA when isPointerType t1 && isIntegralType t2 -> - t1, - optConstFoldBinOp false PlusPI e1 - (mkCastT e2 t2 (integralPromotion t2)) t1 - | PlusA when isIntegralType t1 && isPointerType t2 -> - t2, - optConstFoldBinOp false PlusPI e2 - (mkCastT e1 t1 (integralPromotion t1)) t2 - | MinusA when isPointerType t1 && isIntegralType t2 -> - t1, - optConstFoldBinOp false MinusPI e1 - (mkCastT e2 t2 (integralPromotion t2)) t1 - | MinusA when isPointerType t1 && isPointerType t2 -> - let commontype = t1 in - intType, - optConstFoldBinOp false MinusPP (mkCastT e1 t1 commontype) - (mkCastT e2 t2 commontype) intType - | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> - pointerComparison e1 t1 e2 t2 - | (Eq|Ne) when isPointerType t1 && isZero e2 -> - pointerComparison e1 t1 (mkCastT zero !upointType t1) t1 - | (Eq|Ne) when isPointerType t2 && isZero e1 -> - pointerComparison (mkCastT zero !upointType t2) t2 e2 t2 - - - | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); - (* Cast both values to void * *) - doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType - (mkCastT e2 t2 voidPtrType) voidPtrType - | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); - (* Cast both values to void * *) - doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType - (mkCastT e2 t2 voidPtrType) voidPtrType - - | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType))) - -(* Constant fold a conditional. This is because we want to avoid having - * conditionals in the initializers. So, we try very hard to avoid creating - * new statements. *) -and doCondExp (asconst: bool) (** Try to evaluate the conditional expression - * to TRUE or FALSE, because it occurs in a - * constant *) - (e: A.expression) : condExpRes = - let rec addChunkBeforeCE (c0: chunk) = function - CEExp (c, e) -> CEExp (c0 @@ c, e) - | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2) - | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2) - | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1) - in - let rec canDropCE = function - CEExp (c, e) -> canDrop c - | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2 - | CENot (ce1) -> canDropCE ce1 - in - match e with - A.BINARY (A.AND, e1, e2) -> begin - let ce1 = doCondExp asconst e1 in - let ce2 = doCondExp asconst e2 in - match ce1, ce2 with - CEExp (se1, ((Const _) as ci1)), _ -> - if isConstTrue ci1 then - addChunkBeforeCE se1 ce2 - else - (* se2 might contain labels so we cannot always drop it *) - if canDropCE ce2 then - ce1 - else - CEAnd (ce1, ce2) - | CEExp(se1, e1'), CEExp (se2, e2') when - !useLogicalOperators && isEmpty se1 && isEmpty se2 -> - CEExp (empty, BinOp(LAnd, - mkCast e1' intType, - mkCast e2' intType, intType)) - | _ -> CEAnd (ce1, ce2) - end - - | A.BINARY (A.OR, e1, e2) -> begin - let ce1 = doCondExp asconst e1 in - let ce2 = doCondExp asconst e2 in - match ce1, ce2 with - CEExp (se1, (Const(CInt64 _) as ci1)), _ -> - if isConstFalse ci1 then - addChunkBeforeCE se1 ce2 - else - (* se2 might contain labels so we cannot drop it *) - if canDropCE ce2 then - ce1 - else - CEOr (ce1, ce2) - - | CEExp (se1, e1'), CEExp (se2, e2') when - !useLogicalOperators && isEmpty se1 && isEmpty se2 -> - CEExp (empty, BinOp(LOr, mkCast e1' intType, - mkCast e2' intType, intType)) - | _ -> CEOr (ce1, ce2) - end - - | A.UNARY(A.NOT, e1) -> begin - match doCondExp asconst e1 with - CEExp (se1, (Const _ as ci1)) -> - if isConstFalse ci1 then - CEExp (se1, one) - else - CEExp (se1, zero) - | CEExp (se1, e) when isEmpty se1 -> - let t = typeOf e in - if not ((isPointerType t) || (isArithmeticType t))then - E.s (error "Bad operand to !"); - CEExp (empty, UnOp(LNot, e, intType)) - - | ce1 -> CENot ce1 - end - - | _ -> - let (se, e, t) = doExp asconst e (AExp None) in - ignore (checkBool t e); - CEExp (se, if !lowerConstants then constFold asconst e else e) - -and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk = - match ce with - | CEAnd (ce1, ce2) -> - let (sf1, sf2) = - (* If sf is small then will copy it *) - try (sf, duplicateChunk sf) - with Failure _ -> - let lab = newLabelName "_L" in - (gotoChunk lab lu, consLabel lab sf !currentLoc false) - in - let st' = compileCondExp ce2 st sf1 in - let sf' = sf2 in - compileCondExp ce1 st' sf' - - | CEOr (ce1, ce2) -> - let (st1, st2) = - (* If st is small then will copy it *) - try (st, duplicateChunk st) - with Failure _ -> - let lab = newLabelName "_L" in - (gotoChunk lab lu, consLabel lab st !currentLoc false) - in - let st' = st1 in - let sf' = compileCondExp ce2 st2 sf in - compileCondExp ce1 st' sf' - - | CENot ce1 -> compileCondExp ce1 sf st - - | CEExp (se, e) -> begin - match e with - Const(CInt64(i,_,_)) when i <> Int64.zero && canDrop sf -> se @@ st - | Const(CInt64(z,_,_)) when z = Int64.zero && canDrop st -> se @@ sf - | _ -> se @@ ifChunk e !currentLoc st sf - end - - -(* A special case for conditionals *) -and doCondition (isconst: bool) (* If we are in constants, we do our best to - * eliminate the conditional *) - (e: A.expression) - (st: chunk) - (sf: chunk) : chunk = - compileCondExp (doCondExp isconst e) st sf - - -and doPureExp (e : A.expression) : exp = - let (se, e', _) = doExp true e (AExp None) in - if isNotEmpty se then - E.s (error "doPureExp: not pure"); - e' - -and doInitializer - (vi: varinfo) - (inite: A.init_expression) - (* Return the accumulated chunk, the initializer and the new type (might be - * different for arrays) *) - : chunk * init * typ = - - (* Setup the pre-initializer *) - let topPreInit = ref NoInitPre in - if debugInit then - ignore (E.log "\nStarting a new initializer for %s : %a\n" - vi.vname d_type vi.vtype); - let topSetupInit (o: offset) (e: exp) = - if debugInit then - ignore (E.log " set %a := %a\n" d_lval (Var vi, o) d_exp e); - let newinit = setOneInit !topPreInit o e in - if newinit != !topPreInit then topPreInit := newinit - in - let acc, restl = - let so = makeSubobj vi vi.vtype NoOffset in - doInit vi.vglob topSetupInit so empty [ (A.NEXT_INIT, inite) ] - in - if restl <> [] then - ignore (warn "Ignoring some initializers"); - (* sm: we used to do array-size fixups here, but they only worked - * for toplevel array types; now, collectInitializer does the job, - * including for nested array types *) - let typ' = unrollType vi.vtype in - if debugInit then - ignore (E.log "Collecting the initializer for %s\n" vi.vname); - let (init, typ'') = collectInitializer !topPreInit typ' in - if debugInit then - ignore (E.log "Finished the initializer for %s\n init=%a\n typ=%a\n acc=%a\n" - vi.vname d_init init d_type typ' d_chunk acc); - acc, init, typ'' - - - -(* Consume some initializers. Watch out here. Make sure we use only - * tail-recursion because these things can be big. *) -and doInit - (isconst: bool) - (setone: offset -> exp -> unit) (* Use to announce an intializer *) - (so: subobj) - (acc: chunk) - (initl: (A.initwhat * A.init_expression) list) - - (* Return the resulting chunk along with some unused initializers *) - : chunk * (A.initwhat * A.init_expression) list = - - let whoami () = d_lval () (Var so.host, so.soOff) in - - let initl1 = - match initl with - | (A.NEXT_INIT, - A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest -> - let s', dt', ie' = preprocessCast s dt ie in - (A.NEXT_INIT, A.SINGLE_INIT (A.CAST ((s', dt'), ie'))) :: rest - | _ -> initl - in - (* Sometimes we have a cast in front of a compound (in GCC). This - * appears as a single initializer. Ignore the cast *) - let initl2 = - match initl1 with - (what, - A.SINGLE_INIT (A.CAST (_, A.COMPOUND_INIT ci))) :: rest -> - (what, A.COMPOUND_INIT ci) :: rest - | _ -> initl1 - in - let allinitl = initl2 in - - if debugInit then begin - ignore (E.log "doInit for %t %s (current %a). Looking at: " whoami - (if so.eof then "(eof)" else "") - d_lval (Var so.host, so.curOff)); - (match allinitl with - [] -> ignore (E.log "[]") - | (what, ie) :: _ -> - withCprint - Cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)])); - ignore (E.log "\n"); - end; - match unrollType so.soTyp, allinitl with - _, [] -> acc, [] (* No more initializers return *) - - (* No more subobjects *) - | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl - - - (* If we are at an array of characters and the initializer is a - * string literal (optionally enclosed in braces) then explode the - * string into characters *) - | TArray(bt, leno, _), - (A.NEXT_INIT, - (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))| - A.COMPOUND_INIT - [(A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT - (A.CONST_STRING s)))])) :: restil - when (match unrollType bt with - TInt((IChar|IUChar|ISChar), _) -> true - | TInt _ -> - (*Base type is a scalar other than char. Maybe a wchar_t?*) - E.s (error "Using a string literal to initialize something other than a character array.\n") - | _ -> false (* OK, this is probably an array of strings. Handle *) - ) (* it with the other arrays below.*) - -> - let charinits = - let init c = A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_CHAR [c])) - in - let collector = - (* ISO 6.7.8 para 14: final NUL added only if no size specified, or - * if there is room for it; btw, we can't rely on zero-init of - * globals, since this array might be a local variable *) - if ((isNone leno) or ((String.length s) < (integerArrayLength leno))) - then ref [init Int64.zero] - else ref [] - in - for pos = String.length s - 1 downto 0 do - collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector - done; - !collector - in - (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the array *) - let leno = integerArrayLength leno in - so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc charinits in - if initl' <> [] then - ignore (warn "Too many initializers for character array %t" whoami); - (* Advance past the array *) - advanceSubobj so; - (* Continue *) - let res = doInit isconst setone so acc' restil in - res - - (* If we are at an array of WIDE characters and the initializer is a - * WIDE string literal (optionally enclosed in braces) then explore - * the WIDE string into characters *) - (* [weimer] Wed Jan 30 15:38:05 PST 2002 - * Despite what the compiler says, this match case is used and it is - * important. *) - | TArray(bt, leno, _), - (A.NEXT_INIT, - (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) | - A.COMPOUND_INIT - [(A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT - (A.CONST_WSTRING s)))])) :: restil - when(let bt' = unrollType bt in - match bt' with - (* compare bt to wchar_t, ignoring signed vs. unsigned *) - TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true - | TInt _ -> - (*Base type is a scalar other than wchar_t. Maybe a char?*) - E.s (error "Using a wide string literal to initialize something other than a wchar_t array.\n") - | _ -> false (* OK, this is probably an array of strings. Handle *) - ) (* it with the other arrays below.*) - -> - let maxWChar = (* (2**(bitsSizeOf !wcharType)) - 1 *) - Int64.sub (Int64.shift_left Int64.one (bitsSizeOf !wcharType)) - Int64.one in - let charinits = - let init c = - if (compare c maxWChar > 0) then (* if c > maxWChar *) - E.s (error "cab2cil:doInit:character 0x%Lx too big." c); - A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))) - in - (List.map init s) @ - ( - (* ISO 6.7.8 para 14: final NUL added only if no size specified, or - * if there is room for it; btw, we can't rely on zero-init of - * globals, since this array might be a local variable *) - if ((isNone leno) or ((List.length s) < (integerArrayLength leno))) - then [init Int64.zero] - else []) -(* - List.map - (fun c -> - if (compare c maxWChar > 0) then (* if c > maxWChar *) - E.s (error "cab2cil:doInit:character 0x%Lx too big." c) - else - (A.NEXT_INIT, - A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))))) - s -*) - in - (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the array *) - let leno = integerArrayLength leno in - so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc charinits in - if initl' <> [] then - (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented - * for wchar_t because, as far as I can tell, we don't even put in - * the automatic NUL (!) *) - ignore (warn "Too many initializers for wchar_t array %t" whoami); - (* Advance past the array *) - advanceSubobj so; - (* Continue *) - doInit isconst setone so acc' restil - - (* If we are at an array and we see a single initializer then it must - * be one for the first element *) - | TArray(bt, leno, al), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> - (* Grab the length if there is one *) - let leno = integerArrayLength leno in - so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack; - normalSubobj so; - (* Start over with the fields *) - doInit isconst setone so acc allinitl - - (* If we are at a composite and we see a single initializer of the same - * type as the composite then grab it all. If the type is not the same - * then we must go on and try to initialize the fields *) - | TComp (comp, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> - let se, oneinit', t' = doExp isconst oneinit (AExp None) in - if (match unrollType t' with - TComp (comp', _) when comp'.ckey = comp.ckey -> true - | _ -> false) - then begin - (* Initialize the whole struct *) - setone so.soOff oneinit'; - (* Advance to the next subobject *) - advanceSubobj so; - doInit isconst setone so (acc @@ se) restil - end else begin (* Try to initialize fields *) - let toinit = fieldsToInit comp None in - so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; - normalSubobj so; - doInit isconst setone so acc allinitl - end - - (* A scalar with a single initializer *) - | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> - let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in -(* - ignore (E.log "oneinit'=%a, t'=%a, so.soTyp=%a\n" - d_exp oneinit' d_type t' d_type so.soTyp); -*) - setone so.soOff (mkCastT oneinit' t' so.soTyp); - (* Move on *) - advanceSubobj so; - doInit isconst setone so (acc @@ se) restil - - - (* An array with a compound initializer. The initializer is for the - * array elements *) - | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> - (* Create a separate object for the array *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the array *) - let leno = integerArrayLength leno in - so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc initl in - if initl' <> [] then - ignore (warn "Too many initializers for array %t" whoami); - (* Advance past the array *) - advanceSubobj so; - (* Continue *) - let res = doInit isconst setone so acc' restil in - res - - (* We have a designator that tells us to select the matching union field. - * This is to support a GCC extension *) - | TComp(ci, _), [(A.NEXT_INIT, - A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", - A.NEXT_INIT), - A.SINGLE_INIT oneinit)])] - when not ci.cstruct -> - (* Do the expression to find its type *) - let _, _, t' = doExp isconst oneinit (AExp None) in - let tsig = typeSigWithAttrs (fun _ -> []) t' in - let rec findField = function - [] -> E.s (error "Cannot find matching union field in cast") - | fi :: rest - when Util.equals (typeSigWithAttrs (fun _ -> []) fi.ftype) tsig - -> fi - | _ :: rest -> findField rest - in - let fi = findField ci.cfields in - (* Change the designator and redo *) - doInit isconst setone so acc [(A.INFIELD_INIT (fi.fname, A.NEXT_INIT), - A.SINGLE_INIT oneinit)] - - - (* A structure with a composite initializer. We initialize the fields*) - | TComp (comp, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> - (* Create a separate subobject iterator *) - let so' = makeSubobj so.host so.soTyp so.soOff in - (* Go inside the comp *) - so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)]; - normalSubobj so'; - let acc', initl' = doInit isconst setone so' acc initl in - if initl' <> [] then - ignore (warn "Too many initializers for structure"); - (* Advance past the structure *) - advanceSubobj so; - (* Continue *) - doInit isconst setone so acc' restil - - (* A scalar with a initializer surrounded by braces *) - | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT, - A.SINGLE_INIT oneinit)]) :: restil -> - let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in - setone so.soOff (mkCastT oneinit' t' so.soTyp); - (* Move on *) - advanceSubobj so; - doInit isconst setone so (acc @@ se) restil - - | t, (A.NEXT_INIT, _) :: _ -> - E.s (unimp "doInit: unexpected NEXT_INIT for %a\n" d_type t); - - (* We have a designator *) - | _, (what, ie) :: restil when what != A.NEXT_INIT -> - (* Process a designator and position to the designated subobject *) - let rec addressSubobj - (so: subobj) - (what: A.initwhat) - (acc: chunk) : chunk = - (* Always start from the current element *) - so.stack <- []; so.eof <- false; - normalSubobj so; - let rec address (what: A.initwhat) (acc: chunk) : chunk = - match what with - A.NEXT_INIT -> acc - | A.INFIELD_INIT (fn, whatnext) -> begin - match unrollType so.soTyp with - TComp (comp, _) -> - let toinit = fieldsToInit comp (Some fn) in - so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; - normalSubobj so; - address whatnext acc - - | _ -> E.s (error "Field designator %s not in a struct " fn) - end - - | A.ATINDEX_INIT(idx, whatnext) -> begin - match unrollType so.soTyp with - TArray (bt, leno, _) -> - let ilen = integerArrayLength leno in - let nextidx', doidx = - let (doidx, idxe', _) = - doExp true idx (AExp(Some intType)) in - match constFold true idxe', isNotEmpty doidx with - Const(CInt64(x, _, _)), false -> Int64.to_int x, doidx - | _ -> E.s (error - "INDEX initialization designator is not a constant") - in - if nextidx' < 0 || nextidx' >= ilen then - E.s (error "INDEX designator is outside bounds"); - so.stack <- - InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack; - normalSubobj so; - address whatnext (acc @@ doidx) - - | _ -> E.s (error "INDEX designator for a non-array") - end - - | A.ATINDEXRANGE_INIT _ -> - E.s (bug "addressSubobj: INDEXRANGE") - in - address what acc - in - (* First expand the INDEXRANGE by making copies *) - let rec expandRange (top: A.initwhat -> A.initwhat) = function - | A.INFIELD_INIT (fn, whatnext) -> - expandRange (fun what -> top (A.INFIELD_INIT(fn, what))) whatnext - | A.ATINDEX_INIT (idx, whatnext) -> - expandRange (fun what -> top (A.ATINDEX_INIT(idx, what))) whatnext - - | A.ATINDEXRANGE_INIT (idxs, idxe) -> - let (doidxs, idxs', _) = - doExp true idxs (AExp(Some intType)) in - let (doidxe, idxe', _) = - doExp true idxe (AExp(Some intType)) in - if isNotEmpty doidxs || isNotEmpty doidxe then - E.s (error "Range designators are not constants\n"); - let first, last = - match constFold true idxs', constFold true idxe' with - Const(CInt64(s, _, _)), - Const(CInt64(e, _, _)) -> - Int64.to_int s, Int64.to_int e - | _ -> E.s (error - "INDEX_RANGE initialization designator is not a constant") - in - if first < 0 || first > last then - E.s (error - "start index larger than end index in range initializer"); - let rec loop (i: int) = - if i > last then restil - else - (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)), - A.NEXT_INIT)), ie) - :: loop (i + 1) - in - doInit isconst setone so acc (loop first) - - | A.NEXT_INIT -> (* We have not found any RANGE *) - let acc' = addressSubobj so what acc in - doInit isconst setone so (acc @@ acc') - ((A.NEXT_INIT, ie) :: restil) - in - expandRange (fun x -> x) what - - | t, (what, ie) :: _ -> - E.s (bug "doInit: cases for t=%a" d_type t) - - -(* Create and add to the file (if not already added) a global. Return the - * varinfo *) -and createGlobal (specs : (typ * storage * bool * A.attribute list)) - (((n,ndt,a,cloc), inite) : A.init_name) : varinfo = - try - if debugGlobal then - ignore (E.log "createGlobal: %s\n" n); - (* Make a first version of the varinfo *) - let vi = makeVarInfoCabs ~isformal:false - ~isglobal:true (convLoc cloc) specs (n,ndt,a) in - (* Add the variable to the environment before doing the initializer - * because it might refer to the variable itself *) - if isFunctionType vi.vtype then begin - if inite != A.NO_INIT then - E.s (error "Function declaration with initializer (%s)\n" - vi.vname); - (* sm: if it's a function prototype, and the storage class *) - (* isn't specified, make it 'extern'; this fixes a problem *) - (* with no-storage prototype and static definition *) - if vi.vstorage = NoStorage then - (*(trace "sm" (dprintf "adding extern to prototype of %s\n" n));*) - vi.vstorage <- Extern; - end; - let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in -(* - ignore (E.log "createGlobal %a: %s type=%a\n" - d_loc (convLoc cloc) vi.vname d_plaintype vi.vtype); -*) - (* Do the initializer and complete the array type if necessary *) - let init : init option = - if inite = A.NO_INIT then - None - else - let se, ie', et = doInitializer vi inite in - (* Maybe we now have a better type *) - vi.vtype <- et; - if isNotEmpty se then - E.s (error "global initializer"); - Some ie' - in - - try - let oldloc = H.find alreadyDefined vi.vname in - if init != None then begin - E.s (error "Global %s was already defined at %a\n" - vi.vname d_loc oldloc); - end; - if debugGlobal then - ignore (E.log " global %s was already defined\n" vi.vname); - (* Do not declare it again *) - vi - with Not_found -> begin - (* Not already defined *) - if debugGlobal then - ignore (E.log " first definition for %s\n" vi.vname); - if init != None then begin - (* weimer: Sat Dec 8 17:43:34 2001 - * MSVC NT Kernel headers include this lovely line: - * extern const GUID __declspec(selectany) \ - * MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \ - * 0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } }; - * So we allow "extern" + "initializer" if "const" is - * around. *) - (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8, - * "extern int foo = 3" is exactly equivalent to "int foo = 3"; - * that is, if you put an initializer, then it is a definition, - * and "extern" is redundantly giving the name external linkage. - * gcc emits a warning, I guess because it is contrary to - * usual practice, but I think CIL warnings should be about - * semantic rather than stylistic issues, so I see no reason to - * even emit a warning. *) - if vi.vstorage = Extern then - vi.vstorage <- NoStorage; (* equivalent and canonical *) - - H.add alreadyDefined vi.vname !currentLoc; - IH.remove mustTurnIntoDef vi.vid; - cabsPushGlobal (GVar(vi, {init = init}, !currentLoc)); - vi - end else begin - if not (isFunctionType vi.vtype) - && not (IH.mem mustTurnIntoDef vi.vid) then - begin - IH.add mustTurnIntoDef vi.vid true - end; - if not alreadyInEnv then begin (* Only one declaration *) - (* If it has function type it is a prototype *) - cabsPushGlobal (GVarDecl (vi, !currentLoc)); - vi - end else begin - if debugGlobal then - ignore (E.log " already in env %s\n" vi.vname); - vi - end - end - end - with e -> begin - ignore (E.log "error in createGlobal(%s: %a): %s\n" n - d_loc !currentLoc - (Printexc.to_string e)); - cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)" - n d_thisloc) !currentLoc); - dummyFunDec.svar - end -(* - ignore (E.log "Env after processing global %s is:@!%t@!" - n docEnv); - ignore (E.log "Alpha after processing global %s is:@!%t@!" - n docAlphaTable) -*) - -(* Must catch the Static local variables. Make them global *) -and createLocal ((_, sto, _, _) as specs) - ((((n, ndt, a, cloc) : A.name), - (inite: A.init_expression)) as init_name) - : chunk = - let loc = convLoc cloc in - (* Check if we are declaring a function *) - let rec isProto (dt: decl_type) : bool = - match dt with - | PROTO (JUSTBASE, _, _) -> true - | PROTO (x, _, _) -> isProto x - | PARENTYPE (_, x, _) -> isProto x - | ARRAY (x, _, _) -> isProto x - | PTR (_, x) -> isProto x - | _ -> false - in - match ndt with - (* Maybe we have a function prototype in local scope. Make it global. We - * do this even if the storage is Static *) - | _ when isProto ndt -> - let vi = createGlobal specs init_name in - (* Add it to the environment to shadow previous decls *) - addLocalToEnv n (EnvVar vi); - empty - - | _ when sto = Static -> - if debugGlobal then - ignore (E.log "createGlobal (local static): %s\n" n); - - - (* Now alpha convert it to make sure that it does not conflict with - * existing globals or locals from this function. *) - let newname, _ = newAlphaName true "" n in - (* Make it global *) - let vi = makeVarInfoCabs ~isformal:false - ~isglobal:true - loc specs (newname, ndt, a) in - (* However, we have a problem if a real global appears later with the - * name that we have happened to choose for this one. Remember these names - * for later. *) - H.add staticLocals vi.vname vi; - (* Add it to the environment as a local so that the name goes out of - * scope properly *) - addLocalToEnv n (EnvVar vi); - - (* Maybe this is an array whose length depends on something with local - scope, e.g. "static char device[ sizeof(local) ]". - Const-fold the type to fix this. *) - vi.vtype <- constFoldType vi.vtype; - - let init : init option = - if inite = A.NO_INIT then - None - else begin - let se, ie', et = doInitializer vi inite in - (* Maybe we now have a better type *) - vi.vtype <- et; - if isNotEmpty se then - E.s (error "global static initializer"); - (* Maybe the initializer refers to the function itself. - Push a prototype for the function, just in case. Hopefully, - if does not refer to the locals *) - cabsPushGlobal (GVarDecl (!currentFunctionFDEC.svar, !currentLoc)); - Some ie' - end - in - cabsPushGlobal (GVar(vi, {init = init}, !currentLoc)); - empty - - (* Maybe we have an extern declaration. Make it a global *) - | _ when sto = Extern -> - let vi = createGlobal specs init_name in - (* Add it to the local environment to ensure that it shadows previous - * local variables *) - addLocalToEnv n (EnvVar vi); - empty - - | _ -> - (* Make a variable of potentially variable size. If se0 <> empty then - * it is a variable size variable *) - let vi,se0,len,isvarsize = - makeVarSizeVarInfo loc specs (n, ndt, a) in - - let vi = alphaConvertVarAndAddToEnv true vi in (* Replace vi *) - let se1 = - if isvarsize then begin (* Variable-sized array *) - ignore (warn "Variable-sized local variable %s" vi.vname); - (* Make a local variable to keep the length *) - let savelen = - makeVarInfoCabs - ~isformal:false - ~isglobal:false - loc - (TInt(IUInt, []), NoStorage, false, []) - ("__lengthof" ^ vi.vname,JUSTBASE, []) - in - (* Register it *) - let savelen = alphaConvertVarAndAddToEnv true savelen in - (* Compute the sizeof *) - let sizeof = - BinOp(Mult, - SizeOfE (Lval(Mem(Lval(var vi)), NoOffset)), - Lval (var savelen), !typeOfSizeOf) in - (* Register the length *) - IH.add varSizeArrays vi.vid sizeof; - (* There can be no initializer for this *) - if inite != A.NO_INIT then - E.s (error "Variable-sized array cannot have initializer"); - se0 +++ (Set(var savelen, len, !currentLoc)) - (* Initialize the variable *) - +++ (Call(Some(var vi), Lval(var (allocaFun ())), - [ sizeof ], !currentLoc)) - end else empty - in - if inite = A.NO_INIT then - se1 (* skipChunk *) - else begin - let se4, ie', et = doInitializer vi inite in - (* Fix the length *) - (match vi.vtype, ie', et with - (* We have a length now *) - TArray(_,None, _), _, TArray(_, Some _, _) -> vi.vtype <- et - (* Initializing a local array *) - | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a), - SingleInit(Const(CStr s)), _ -> - vi.vtype <- TArray(bt, - Some (integer (String.length s + 1)), - a) - | _, _, _ -> ()); - - (* Now create assignments instead of the initialization *) - se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty) - end - -and doAliasFun vtype (thisname:string) (othername:string) - (sname:single_name) (loc: cabsloc) : unit = - (* This prototype declares that name is an alias for - othername, which must be defined in this file *) -(* E.log "%s is alias for %s at %a\n" thisname othername *) -(* d_loc !currentLoc; *) - let rt, formals, isva, _ = splitFunctionType vtype in - if isva then E.s (error "%a: alias unsupported with varargs." - d_loc !currentLoc); - let args = List.map - (fun (n,_,_) -> A.VARIABLE n) - (argsToList formals) in - let call = A.CALL (A.VARIABLE othername, args) in - let stmt = if isVoidType rt then A.COMPUTATION(call, loc) - else A.RETURN(call, loc) - in - let body = { A.blabels = []; A.battrs = []; A.bstmts = [stmt] } in - let fdef = A.FUNDEF (sname, body, loc, loc) in - ignore (doDecl true fdef); - (* get the new function *) - let v,_ = try lookupGlobalVar thisname - with Not_found -> E.s (bug "error in doDecl") in - v.vattr <- dropAttribute "alias" v.vattr - - -(* Do one declaration *) -and doDecl (isglobal: bool) : A.definition -> chunk = function - | A.DECDEF ((s, nl), loc) -> - currentLoc := convLoc(loc); - (* Do the specifiers exactly once *) - let sugg = - match nl with - [] -> "" - | ((n, _, _, _), _) :: _ -> n - in - let spec_res = doSpecList sugg s in - (* Do all the variables and concatenate the resulting statements *) - let doOneDeclarator (acc: chunk) (name: init_name) = - let (n,ndt,a,l),_ = name in - if isglobal then begin - let bt,_,_,attrs = spec_res in - let vtype, nattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in - (match filterAttributes "alias" nattr with - [] -> (* ordinary prototype. *) - ignore (createGlobal spec_res name) - (* E.log "%s is not aliased\n" name *) - | [Attr("alias", [AStr othername])] -> - if not (isFunctionType vtype) then begin - ignore (warn - "%a: CIL only supports attribute((alias)) for functions.\n" - d_loc !currentLoc); - ignore (createGlobal spec_res name) - end else - doAliasFun vtype n othername (s, (n,ndt,a,l)) loc - | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc)); - acc - end else - acc @@ createLocal spec_res name - in - let res = List.fold_left doOneDeclarator empty nl in -(* - ignore (E.log "after doDecl %a: res=%a\n" - d_loc !currentLoc d_chunk res); -*) - res - - - - | A.TYPEDEF (ng, loc) -> - currentLoc := convLoc(loc); - doTypedef ng; empty - - | A.ONLYTYPEDEF (s, loc) -> - currentLoc := convLoc(loc); - doOnlyTypedef s; empty - - | A.GLOBASM (s,loc) when isglobal -> - currentLoc := convLoc(loc); - cabsPushGlobal (GAsm (s, !currentLoc)); - empty - - | A.PRAGMA (a, loc) when isglobal -> begin - currentLoc := convLoc(loc); - match doAttr ("dummy", [a]) with - [Attr("dummy", [a'])] -> - let a'' = - match a' with - | ACons (s, args) -> Attr (s, args) - | _ -> E.s (error "Unexpected attribute in #pragma") - in - cabsPushGlobal (GPragma (a'', !currentLoc)); - empty - - | _ -> E.s (error "Too many attributes in pragma") - end - | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input") - | A.EXPRTRANSFORMER (_, _, _) -> - E.s (E.bug "EXPRTRANSFORMER in cabs2cil input") - - (* If there are multiple definitions of extern inline, turn all but the - * first into a prototype *) - | A.FUNDEF (((specs,(n,dt,a,loc')) : A.single_name), - (body : A.block), loc, _) - when isglobal && isExtern specs && isInline specs - && (H.mem genv (n ^ "__extinline")) -> - currentLoc := convLoc(loc); - let othervi, _ = lookupVar (n ^ "__extinline") in - if othervi.vname = n then - (* The previous entry in the env is also an extern inline version - of n. *) - ignore (warn "Duplicate extern inline definition for %s ignored" n) - else begin - (* Otherwise, the previous entry is an ordinary function that - happens to be named __extinline. Renaming n to n__extinline - would confict with other, so report an error. *) - E.s (unimp("Trying to rename %s to\n %s__extinline, but %s__extinline" - ^^ " already exists in the env.\n \"__extinline\" is" - ^^ " reserved for CIL.\n") n n n) - end; - (* Treat it as a prototype *) - doDecl isglobal (A.DECDEF ((specs, [((n,dt,a,loc'), A.NO_INIT)]), loc)) - - | A.FUNDEF (((specs,(n,dt,a, _)) : A.single_name), - (body : A.block), loc1, loc2) when isglobal -> - begin - let funloc = convLoc loc1 in - let endloc = convLoc loc2 in -(* ignore (E.log "Definition of %s at %a\n" n d_loc funloc); *) - currentLoc := funloc; - E.withContext - (fun _ -> dprintf "2cil: %s" n) - (fun _ -> - try - IH.clear callTempVars; - - (* Make the fundec right away, and we'll populate it later. We - * need this throughout the code to create temporaries. *) - currentFunctionFDEC := - { svar = makeGlobalVar "@tempname@" voidType; - slocals = []; (* For now we'll put here both the locals and - * the formals. Then "endFunction" will - * separate them *) - sformals = []; (* Not final yet *) - smaxid = 0; - sbody = dummyFunDec.sbody; (* Not final yet *) - smaxstmtid = None; - sallstmts = []; - }; - !currentFunctionFDEC.svar.vdecl <- funloc; - - constrExprId := 0; - (* Setup the environment. Add the formals to the locals. Maybe - * they need alpha-conv *) - enterScope (); (* Start the scope *) - - IH.clear varSizeArrays; - - (* Do not process transparent unions in function definitions. - * We'll do it later *) - transparentUnionArgs := []; - - (* Fix the NAME and the STORAGE *) - let _ = - let bt,sto,inl,attrs = doSpecList n specs in - !currentFunctionFDEC.svar.vinline <- inl; - - let ftyp, funattr = - doType (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in - !currentFunctionFDEC.svar.vtype <- ftyp; - !currentFunctionFDEC.svar.vattr <- funattr; - - (* If this is the definition of an extern inline then we change - * its name, by adding the suffix __extinline. We also make it - * static *) - let n', sto' = - let n' = n ^ "__extinline" in - if inl && sto = Extern then - n', Static - else begin - (* Maybe this is the body of a previous extern inline. Then - * we must take that one out of the environment because it - * is not used from here on. This will also ensure that - * then we make this functions' varinfo we will not think - * it is a duplicate definition *) - (try - ignore (lookupVar n'); (* if this succeeds, n' is defined*) - let oldvi, _ = lookupVar n in - if oldvi.vname = n' then begin - (* oldvi is an extern inline function that has been - renamed to n ^ "__extinline". Remove it from the - environment. *) - H.remove env n; H.remove genv n; - H.remove env n'; H.remove genv n' - end - else - (* oldvi is not a renamed extern inline function, and - we should do nothing. The reason the lookup - of n' succeeded is probably because there's - an ordinary function that happens to be named, - n ^ "__extinline", probably as a result of a previous - pass through CIL. See small2/extinline.c*) - () - with Not_found -> ()); - n, sto - end - in - (* Now we have the name and the storage *) - !currentFunctionFDEC.svar.vname <- n'; - !currentFunctionFDEC.svar.vstorage <- sto' - in - - (* Add the function itself to the environment. Add it before - * you do the body because the function might be recursive. Add - * it also before you add the formals to the environment - * because there might be a formal with the same name as the - * function and we want it to take precedence. *) - (* Make a variable out of it and put it in the environment *) - !currentFunctionFDEC.svar <- - fst (makeGlobalVarinfo true !currentFunctionFDEC.svar); - - (* If it is extern inline then we add it to the global - * environment for the original name as well. This will ensure - * that all uses of this function will refer to the renamed - * function *) - addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar); - - if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then - E.s (error "There is a definition already for %s" n); - -(* - ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!" - n d_type thisFunctionVI.vtype - d_attrlist thisFunctionVI.vattr); -*) - - (* makeGlobalVarinfo might have changed the type of the function - * (when combining it with the type of the prototype). So get the - * type only now. *) - - (**** Process the TYPE and the FORMALS ***) - let _ = - let (returnType, formals_t, isvararg, funta) = - splitFunctionTypeVI !currentFunctionFDEC.svar - in - (* Record the returnType for doStatement *) - currentReturnType := returnType; - - - (* Create the formals and add them to the environment. *) - (* sfg: extract locations for the formals from dt *) - let doFormal (loc : location) (fn, ft, fa) = - let f = makeVarinfo false fn ft in - (f.vdecl <- loc; - f.vattr <- fa; - alphaConvertVarAndAddToEnv true f) - in - let rec doFormals fl' ll' = - begin - match (fl', ll') with - | [], _ -> [] - - | fl, [] -> (* no more locs available *) - List.map (doFormal !currentLoc) fl - - | f::fl, (_,(_,_,_,l))::ll -> - (* sfg: these lets seem to be necessary to - * force the right order of evaluation *) - let f' = doFormal (convLoc l) f in - let fl' = doFormals fl ll in - f' :: fl' - end - in - let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in - let formals = doFormals (argsToList formals_t) fmlocs in - - (* Recreate the type based on the formals. *) - let ftype = TFun(returnType, - Some (List.map (fun f -> (f.vname, - f.vtype, - f.vattr)) formals), - isvararg, funta) in - (* - ignore (E.log "Funtype of %s: %a\n" n' d_type ftype); - *) - (* Now fix the names of the formals in the type of the function - * as well *) - !currentFunctionFDEC.svar.vtype <- ftype; - !currentFunctionFDEC.sformals <- formals; - in - (* Now change the type of transparent union args back to what it - * was so that the body type checks. We must do it this late - * because makeGlobalVarinfo from above might choke if we give - * the function a type containing transparent unions *) - let _ = - let rec fixbackFormals (idx: int) (args: varinfo list) : unit= - match args with - [] -> () - | a :: args' -> - (* Fix the type back to a transparent union type *) - (try - let origtype = List.assq idx !transparentUnionArgs in - a.vtype <- origtype; - with Not_found -> ()); - fixbackFormals (idx + 1) args' - in - fixbackFormals 0 !currentFunctionFDEC.sformals; - transparentUnionArgs := []; - in - - (********** Now do the BODY *************) - let _ = - let stmts = doBody body in - (* Finish everything *) - exitScope (); - - (* Now fill in the computed goto statement with cases. Do this - * before mkFunctionbody which resolves the gotos *) - (match !gotoTargetData with - Some (switchv, switch) -> - let switche, l = - match switch.skind with - Switch (switche, _, _, l) -> switche, l - | _ -> E.s(bug "the computed goto statement not a switch") - in - (* Build a default chunk that segfaults *) - let default = - defaultChunk - l - (i2c (Set ((Mem (mkCast (integer 0) intPtrType), - NoOffset), - integer 0, l))) - in - let bodychunk = ref default in - H.iter (fun lname laddr -> - bodychunk := - caseRangeChunk - [integer laddr] l - (gotoChunk lname l @@ !bodychunk)) - gotoTargetHash; - (* Now recreate the switch *) - let newswitch = switchChunk switche !bodychunk l in - (* We must still share the old switch statement since we - * have already inserted the goto's *) - let newswitchkind = - match newswitch.stmts with - [ s] - when newswitch.postins == [] && newswitch.cases == []-> - s.skind - | _ -> E.s (bug "Unexpected result from switchChunk") - in - switch.skind <- newswitchkind - - | None -> ()); - (* Now finish the body and store it *) - !currentFunctionFDEC.sbody <- mkFunctionBody stmts; - (* Reset the global parameters *) - gotoTargetData := None; - H.clear gotoTargetHash; - gotoTargetNextAddr := 0; - in - - - -(* - ignore (E.log "endFunction %s at %t:@! sformals=%a@! slocals=%a@!" - !currentFunctionFDEC.svar.vname d_thisloc - (docList ~sep:(chr ',') (fun v -> text v.vname)) - !currentFunctionFDEC.sformals - (docList ~sep:(chr ',') (fun v -> text v.vname)) - !currentFunctionFDEC.slocals); -*) - - let rec dropFormals formals locals = - match formals, locals with - [], l -> l - | f :: formals, l :: locals -> - if f != l then - E.s (bug "formal %s is not in locals (found instead %s)" - f.vname l.vname); - dropFormals formals locals - | _ -> E.s (bug "Too few locals") - in - !currentFunctionFDEC.slocals - <- dropFormals !currentFunctionFDEC.sformals - (List.rev !currentFunctionFDEC.slocals); - setMaxId !currentFunctionFDEC; - - (* Now go over the types of the formals and pull out the formals - * with transparent union type. Replace them with some shadow - * parameters and then add assignments *) - let _ = - let newformals, newbody = - List.fold_right (* So that the formals come out in order *) - (fun f (accform, accbody) -> - match isTransparentUnion f.vtype with - None -> (f :: accform, accbody) - | Some fstfield -> - (* A new shadow to be placed in the formals. Use - * makeTempVar to update smaxid and all others. *) - let shadow = - makeTempVar !currentFunctionFDEC fstfield.ftype in - (* Now take it out of the locals and replace it with - * the current formal. It is not worth optimizing this - * one. *) - !currentFunctionFDEC.slocals <- - f :: - (List.filter (fun x -> x.vid <> shadow.vid) - !currentFunctionFDEC.slocals); - (shadow :: accform, - mkStmt (Instr [Set ((Var f, Field(fstfield, - NoOffset)), - Lval (var shadow), - !currentLoc)]) :: accbody)) - !currentFunctionFDEC.sformals - ([], !currentFunctionFDEC.sbody.bstmts) - in - !currentFunctionFDEC.sbody.bstmts <- newbody; - (* To make sure sharing with the type is proper *) - setFormals !currentFunctionFDEC newformals; - in - - (* Now see whether we can fall through to the end of the function - * *) - (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include - * functions like long convert(x) { __asm { mov eax, x \n cdq } } - * That set a return value via an ASM statement. As a result, I - * am changing this so a final ASM statement does not count as - * "fall through" for the purposes of this warning. *) - (* matth: But it's better to assume assembly will fall through, - * since most such blocks do. It's probably better to print an - * unnecessary warning than to break CIL's invariant that - * return statements are inserted properly. *) - let instrFallsThrough (i : instr) = match i with - Set _ -> true - | Call (None, Lval (Var e, NoOffset), _, _) -> - (* See if this is exit, or if it has the noreturn attribute *) - if e.vname = "exit" then false - else if hasAttribute "noreturn" e.vattr then false - else true - | Call _ -> true - | Asm _ -> true - in - let rec stmtFallsThrough (s: stmt) : bool = - match s.skind with - Instr(il) -> - List.fold_left (fun acc elt -> - acc && instrFallsThrough elt) true il - | Return _ | Break _ | Continue _ -> false - | Goto _ -> false - | If (_, b1, b2, _) -> - blockFallsThrough b1 || blockFallsThrough b2 - | Switch (e, b, targets, _) -> - (* See if there is a "default" case *) - if not - (List.exists (fun s -> - List.exists (function Default _ -> true | _ -> false) - s.labels) - targets) then begin -(* - ignore (E.log "Switch falls through because no default"); - -*) true (* We fall through because there is no default *) - end else begin - (* We must examine all cases. If any falls through, - * then the switch falls through. *) - blockFallsThrough b || blockCanBreak b - end -(* - | Loop (b, _, _, _) -> - (* A loop falls through if it can break. *) - blockCanBreak b -*) - | While (_, b, _) -> blockCanBreak b - | DoWhile (_, b, _) -> blockCanBreak b - | For (_, _, _, b, _) -> blockCanBreak b - | Block b -> blockFallsThrough b - | TryFinally (b, h, _) -> blockFallsThrough h - | TryExcept (b, _, h, _) -> true (* Conservative *) - and blockFallsThrough b = - let rec fall = function - [] -> true - | s :: rest -> - if stmtFallsThrough s then begin -(* - ignore (E.log "Stmt %a falls through\n" d_stmt s); -*) - fall rest - end else begin -(* - ignore (E.log "Stmt %a DOES NOT fall through\n" - d_stmt s); -*) - (* If we are not falling thorough then maybe there - * are labels who are *) - labels rest - end - and labels = function - [] -> false - (* We have a label, perhaps we can jump here *) - | s :: rest when s.labels <> [] -> -(* - ignore (E.log "invoking fall %a: %a\n" - d_loc !currentLoc d_stmt s); -*) - fall (s :: rest) - | _ :: rest -> labels rest - in - let res = fall b.bstmts in -(* - ignore (E.log "blockFallsThrough=%b %a\n" res d_block b); -*) - res - (* will we leave this statement or block with a break command? *) - and stmtCanBreak (s: stmt) : bool = - match s.skind with - Instr _ | Return _ | Continue _ | Goto _ -> false - | Break _ -> true - | If (_, b1, b2, _) -> - blockCanBreak b1 || blockCanBreak b2 - | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ -> - (* switches and loops catch any breaks in their bodies *) - false - | Block b -> blockCanBreak b - | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h - | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h - and blockCanBreak b = - List.exists stmtCanBreak b.bstmts - in - if blockFallsThrough !currentFunctionFDEC.sbody then begin -(* - let retval = - match unrollType !currentReturnType with - TVoid _ -> None - | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> - ignore (warn "Body of function %s falls-through. Adding a return statement\n" !currentFunctionFDEC.svar.vname); - Some (mkCastT zero intType rt) - | _ -> - ignore (warn "Body of function %s falls-through and cannot find an appropriate return value\n" !currentFunctionFDEC.svar.vname); - None - in - if not (hasAttribute "noreturn" - !currentFunctionFDEC.svar.vattr) then - !currentFunctionFDEC.sbody.bstmts <- - !currentFunctionFDEC.sbody.bstmts - @ [mkStmt (Return(retval, endloc))] -*) - end; - - (* ignore (E.log "The env after finishing the body of %s:\n%t\n" - n docEnv); *) - cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); - empty - with E.Error as e -> raise e - | e -> begin - ignore (E.log "error in collectFunction %s: %s\n" - n (Printexc.to_string e)); - cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc)); - empty - end) - () (* argument of E.withContext *) - end (* FUNDEF *) - - | LINKAGE (n, loc, dl) -> - currentLoc := convLoc loc; - if n <> "C" then - ignore (warn "Encountered linkage specification \"%s\"" n); - if not isglobal then - E.s (error "Encountered linkage specification in local scope"); - (* For now drop the linkage on the floor !!! *) - List.iter - (fun d -> - let s = doDecl isglobal d in - if isNotEmpty s then - E.s (bug "doDecl returns non-empty statement for global")) - dl; - empty - - | _ -> E.s (error "unexpected form of declaration") - -and doTypedef ((specs, nl): A.name_group) = - try - (* Do the specifiers exactly once *) - let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in - if sto <> NoStorage || inl then - E.s (error "Storage or inline specifier not allowed in typedef"); - let createTypedef ((n,ndt,a,loc) : A.name) = - (* E.s (error "doTypeDef") *) - try - let newTyp, tattr = - doType AttrType bt (A.PARENTYPE(attrs, ndt, a)) in - let newTyp' = cabsTypeAddAttributes tattr newTyp in - (* Create a new name for the type. Use the same name space as that of - * variables to avoid confusion between variable names and types. This - * is actually necessary in some cases. *) - let n', _ = newAlphaName true "" n in - let ti = { tname = n'; ttype = newTyp'; treferenced = false } in - (* Since we use the same name space, we might later hit a global with - * the same name and we would want to change the name of the global. - * It is better to change the name of the type instead. So, remember - * all types whose names have changed *) - H.add typedefs n' ti; - let namedTyp = TNamed(ti, []) in - (* Register the type. register it as local because we might be in a - * local context *) - addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp); - cabsPushGlobal (GType (ti, !currentLoc)) - with E.Error as e -> raise e - | e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc)) - end - in - List.iter createTypedef nl - with E.Error as e -> raise e - | e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - let fstname = - match nl with - [] -> "" - | (n, _, _, _) :: _ -> n - in - cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc)) - end - -and doOnlyTypedef (specs: A.spec_elem list) : unit = - try - let bt, sto, inl, attrs = doSpecList "" specs in - if sto <> NoStorage || inl then - E.s (error "Storage or inline specifier not allowed in typedef"); - let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs, - A.JUSTBASE, [])) in - if nattr <> [] then - ignore (warn "Ignoring identifier attribute"); - (* doSpec will register the type. *) - (* See if we are defining a composite or enumeration type, and in that - * case move the attributes from the defined type into the composite type - * *) - let isadef = - List.exists - (function - A.SpecType(A.Tstruct(_, Some _, _)) -> true - | A.SpecType(A.Tunion(_, Some _, _)) -> true - | A.SpecType(A.Tenum(_, Some _, _)) -> true - | _ -> false) specs - in - match restyp with - TComp(ci, al) -> - if isadef then begin - ci.cattr <- cabsAddAttributes ci.cattr al; - (* The GCompTag was already added *) - end else (* Add a GCompTagDecl *) - cabsPushGlobal (GCompTagDecl(ci, !currentLoc)) - | TEnum(ei, al) -> - if isadef then begin - ei.eattr <- cabsAddAttributes ei.eattr al; - end else - cabsPushGlobal (GEnumTagDecl(ei, !currentLoc)) - | _ -> - ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n") - - with E.Error as e -> raise e - | e -> begin - ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef", !currentLoc)) - end - -and assignInit (lv: lval) - (ie: init) - (iet: typ) - (acc: chunk) : chunk = - match ie with - SingleInit e -> - let (_, e'') = castTo iet (typeOfLval lv) e in - acc +++ (Set(lv, e'', !currentLoc)) - | CompoundInit (t, initl) -> - foldLeftCompound - ~doinit:(fun off i it acc -> - assignInit (addOffsetLval off lv) i it acc) - ~ct:t - ~initl:initl - ~acc:acc -(* - | ArrayInit (bt, len, initl) -> - let idx = ref ( -1 ) in - List.fold_left - (fun acc i -> - assignInit (addOffsetLval (Index(integer !idx, NoOffset)) lv) i bt acc) - acc - initl -*) - (* Now define the processors for body and statement *) -and doBody (blk: A.block) : chunk = - enterScope (); - (* Rename the labels and add them to the environment *) - List.iter (fun l -> ignore (genNewLocalLabel l)) blk.blabels; - (* See if we have some attributes *) - let battrs = doAttributes blk.A.battrs in - - let bodychunk = - afterConversion - (List.fold_left (* !!! @ evaluates its arguments backwards *) - (fun prev s -> let res = doStatement s in - prev @@ res) - empty - blk.A.bstmts) - in - exitScope (); - - - if battrs == [] then - bodychunk - else begin - let b = c2block bodychunk in - b.battrs <- battrs; - s2c (mkStmt (Block b)) - end - -and doStatement (s : A.statement) : chunk = - try - match s with - A.NOP _ -> skipChunk - | A.COMPUTATION (e, loc) -> - currentLoc := convLoc loc; - let (lasts, data) = !gnu_body_result in - if lasts == s then begin (* This is the last in a GNU_BODY *) - let (s', e', t') = doExp false e (AExp None) in - data := Some (e', t'); (* Record the result *) - s' - end else - let (s', _, _) = doExp false e ADrop in - (* drop the side-effect free expression *) - (* And now do some peep-hole optimizations *) - s' - - | A.BLOCK (b, loc) -> - currentLoc := convLoc loc; - doBody b - - | A.SEQUENCE (s1, s2, loc) -> - (doStatement s1) @@ (doStatement s2) - - | A.IF(e,st,sf,loc) -> - let st' = doStatement st in - let sf' = doStatement sf in - currentLoc := convLoc loc; - doCondition false e st' sf' - - | A.WHILE(e,s,loc) -> -(* - startLoop true; - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - loopChunk ((doCondition false e skipChunk - (breakChunk loc')) - @@ s') -*) - (** We need to convert A.WHILE(e,s) where e may have side effects - into Cil.While(e',s') where e' is side-effect free. *) - - (* Let e == (sCond , eCond) with sCond a sequence of statements - and eCond a side-effect free expression. *) - let (sCond, eCond, _) = doExp false e (AExp None) in - - (* Then doStatement(A.WHILE((sCond , eCond), s)) - = sCond ; Cil.While(eCond, (doStatement(s) ; sCond)) - where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) - - startLoop (DuplicateBeforeContinue sCond); - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - sCond @@ (whileChunk eCond (s' @@ sCond)) - - | A.DOWHILE(e,s,loc) -> -(* - startLoop false; - let s' = doStatement s in - let loc' = convLoc loc in - currentLoc := loc'; - let s'' = - consLabContinue (doCondition false e skipChunk (breakChunk loc')) - in - exitLoop (); - loopChunk (s' @@ s'') -*) - (** We need to convert A.DOWHILE(e,s) where e may have side effects - into Cil.DoWhile(e',s') where e' is side-effect free. *) - - (* Let e == (sCond , eCond) with sCond a sequence of statements - and eCond a side-effect free expression. *) - let (sCond, eCond, _) = doExp false e (AExp None) in - - (* Then doStatement(A.DOWHILE((sCond , eCond), s)) - = Cil.DoWhile(eCond, (doStatement(s) ; sCond)) - where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) - - startLoop (DuplicateBeforeContinue sCond); - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - doWhileChunk eCond (s' @@ sCond) - - | A.FOR(fc1,e2,e3,s,loc) -> -(*begin - let loc' = convLoc loc in - currentLoc := loc'; - enterScope (); (* Just in case we have a declaration *) - let (se1, _, _) = - match fc1 with - FC_EXP e1 -> doExp false e1 ADrop - | FC_DECL d1 -> (doDecl false d1, zero, voidType) - in - let (se3, _, _) = doExp false e3 ADrop in - startLoop false; - let s' = doStatement s in - currentLoc := loc'; - let s'' = consLabContinue se3 in - exitLoop (); - let res = - match e2 with - A.NOTHING -> (* This means true *) - se1 @@ loopChunk (s' @@ s'') - | _ -> - se1 @@ loopChunk ((doCondition false e2 skipChunk (breakChunk loc')) - @@ s' @@ s'') - in - exitScope (); - res - end -*) - (** We need to convert A.FOR(e1,e2,e3,s) where e1, e2 and e3 may - have side effects into Cil.For(bInit,e2',bIter,s') where e2' - is side-effect free. **) - - (* Let e1 == bInit be a block of statements - Let e2 == (bCond , eCond) with bCond a block of statements - and eCond a side-effect free expression - Let e3 == bIter be a sequence of statements. *) - let (bInit, _, _) = match fc1 with - | FC_EXP e1 -> doExp false e1 ADrop - | FC_DECL d1 -> (doDecl false d1, zero, voidType) in - let (bCond, eCond, _) = doExp false e2 (AExp None) in - let eCond' = match eCond with - | Const(CStr "exp_nothing") -> Cil.one - | _ -> eCond in - let (bIter, _, _) = doExp false e3 ADrop in - - (* Then doStatement(A.FOR(bInit, (bCond , eCond), bIter, s)) - = Cil.For({bInit; bCond}, eCond', {bIter; bCond}, {doStatement(s)}) - where doStatement(A.CONTINUE) = Cil.Continue. *) - - startLoop ContinueUnchanged; - let s' = doStatement s in - exitLoop (); - let loc' = convLoc loc in - currentLoc := loc'; - (forChunk (bInit @@ bCond) eCond' (bIter @@ bCond) s') - - | A.BREAK loc -> - let loc' = convLoc loc in - currentLoc := loc'; - breakChunk loc' - - | A.CONTINUE loc -> - let loc' = convLoc loc in - currentLoc := loc'; -(* - continueOrLabelChunk loc' -*) - continueDuplicateChunk loc' - - | A.RETURN (A.NOTHING, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - if not (isVoidType !currentReturnType) then - ignore (warn "Return statement without a value in function returning %a\n" d_type !currentReturnType); - returnChunk None loc' - - | A.RETURN (e, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - (* Sometimes we return the result of a void function call *) - if isVoidType !currentReturnType then begin - ignore (warn "Return statement with a value in function returning void"); - let (se, _, _) = doExp false e ADrop in - se @@ returnChunk None loc' - end else begin - let (se, e', et) = - doExp false e (AExp (Some !currentReturnType)) in - let (et'', e'') = castTo et (!currentReturnType) e' in - se @@ (returnChunk (Some e'') loc') - end - - | A.SWITCH (e, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let (se, e', et) = doExp false e (AExp (Some intType)) in - let (et'', e'') = castTo et intType e' in - let s' = doStatement s in - se @@ (switchChunk e'' s' loc') - - | A.CASE (e, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let (se, e', et) = doExp true e (AExp None) in - if isNotEmpty se then - E.s (error "Case statement with a non-constant"); - caseRangeChunk [if !lowerConstants then constFold false e' else e'] - loc' (doStatement s) - - | A.CASERANGE (el, eh, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let (sel, el', etl) = doExp false el (AExp None) in - let (seh, eh', etl) = doExp false eh (AExp None) in - if isNotEmpty sel || isNotEmpty seh then - E.s (error "Case statement with a non-constant"); - let il, ih = - match constFold true el', constFold true eh' with - Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) -> - Int64.to_int il, Int64.to_int ih - | _ -> E.s (unimp "Cannot understand the constants in case range") - in - if il > ih then - E.s (error "Empty case range"); - let rec mkAll (i: int) = - if i > ih then [] else integer i :: mkAll (i + 1) - in - caseRangeChunk (mkAll il) loc' (doStatement s) - - - | A.DEFAULT (s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - defaultChunk loc' (doStatement s) - - | A.LABEL (l, s, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - (* Lookup the label because it might have been locally defined *) - consLabel (lookupLabel l) (doStatement s) loc' true - - | A.GOTO (l, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - (* Maybe we need to rename this label *) - gotoChunk (lookupLabel l) loc' - - | A.COMPGOTO (e, loc) -> begin - let loc' = convLoc loc in - currentLoc := loc'; - (* Do the expression *) - let se, e', t' = doExp false e (AExp (Some voidPtrType)) in - match !gotoTargetData with - Some (switchv, switch) -> (* We have already generated this one *) - se - @@ i2c(Set (var switchv, mkCast e' uintType, loc')) - @@ s2c(mkStmt(Goto (ref switch, loc'))) - - | None -> begin - (* Make a temporary variable *) - let vchunk = createLocal - (TInt(IUInt, []), NoStorage, false, []) - (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT) - in - if not (isEmpty vchunk) then - E.s (unimp "Non-empty chunk in creating temporary for goto *"); - let switchv, _ = - try lookupVar "__compgoto" - with Not_found -> E.s (bug "Cannot find temporary for goto *"); - in - (* Make a switch statement. We'll fill in the statements at the - * end of the function *) - let switch = mkStmt (Switch (Lval(var switchv), - mkBlock [], [], loc')) in - (* And make a label for it since we'll goto it *) - switch.labels <- [Label ("__docompgoto", loc', false)]; - gotoTargetData := Some (switchv, switch); - se @@ i2c (Set(var switchv, mkCast e' uintType, loc')) @@ - s2c switch - end - end - - | A.DEFINITION d -> - let s = doDecl false d in -(* - ignore (E.log "Def at %a: %a\n" d_loc !currentLoc d_chunk s); -*) - s - - - - | A.ASM (asmattr, tmpls, details, loc) -> - (* Make sure all the outs are variables *) - let loc' = convLoc loc in - let attr' = doAttributes asmattr in - currentLoc := loc'; - let stmts : chunk ref = ref empty in - let (tmpls', outs', ins', clobs') = - match details with - | None -> - let tmpls' = - if !msvcMode then - tmpls - else - let pattern = Str.regexp "%" in - let escape = Str.global_replace pattern "%%" in - List.map escape tmpls - in - (tmpls', [], [], []) - | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> - let outs' = - List.map - (fun (c, e) -> - let (se, e', t) = doExp false e (AExp None) in - let lv = - match e' with - | Lval lval - | StartOf lval -> lval - | _ -> E.s (error "Expected lval for ASM outputs") - in - stmts := !stmts @@ se; - (c, lv)) outs - in - (* Get the side-effects out of expressions *) - let ins' = - List.map - (fun (c, e) -> - let (se, e', et) = doExp false e (AExp None) in - stmts := !stmts @@ se; - (c, e')) - ins - in - (tmpls, outs', ins', clobs) - in - !stmts @@ - (i2c (Asm(attr', tmpls', outs', ins', clobs', loc'))) - - | TRY_FINALLY (b, h, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let b': chunk = doBody b in - let h': chunk = doBody h in - if b'.cases <> [] || h'.cases <> [] then - E.s (error "Try statements cannot contain switch cases"); - - s2c (mkStmt (TryFinally (c2block b', c2block h', loc'))) - - | TRY_EXCEPT (b, e, h, loc) -> - let loc' = convLoc loc in - currentLoc := loc'; - let b': chunk = doBody b in - (* Now do e *) - let ((se: chunk), e', t') = doExp false e (AExp None) in - let h': chunk = doBody h in - if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then - E.s (error "Try statements cannot contain switch cases"); - (* Now take se and try to convert it to a list of instructions. This - * might not be always possible *) - let il' = - match compactStmts se.stmts with - [] -> se.postins - | [ s ] -> begin - match s.skind with - Instr il -> il @ se.postins - | _ -> E.s (error "Except expression contains unexpected statement") - end - | _ -> E.s (error "Except expression contains too many statements") - in - s2c (mkStmt (TryExcept (c2block b', (il', e'), c2block h', loc'))) - - with e -> begin - (ignore (E.log "Error in doStatement (%s)\n" (Printexc.to_string e))); - consLabel "booo_statement" empty (convLoc (A.get_statementloc s)) false - end - - -(* Translate a file *) -let convFile ((fname : string), (dl : Cabs.definition list)) : Cil.file = - Cil.initCIL (); (* make sure we have initialized CIL *) - (* Clean up the global types *) - E.hadErrors := false; - initGlobals(); - startFile (); - IH.clear noProtoFunctions; - H.clear compInfoNameEnv; - H.clear enumInfoNameEnv; - IH.clear mustTurnIntoDef; - H.clear alreadyDefined; - H.clear staticLocals; - H.clear typedefs; - H.clear isomorphicStructs; - annonCompFieldNameId := 0; - if !E.verboseFlag || !Cilutil.printStages then - ignore (E.log "Converting CABS->CIL\n"); - (* Setup the built-ins, but do not add their prototypes to the file *) - let setupBuiltin name (resTyp, argTypes, isva) = - let v = - makeGlobalVar name (TFun(resTyp, - Some (List.map (fun at -> ("", at, [])) - argTypes), - isva, [])) in - ignore (alphaConvertVarAndAddToEnv true v) - in - H.iter setupBuiltin (if !msvcMode then msvcBuiltins else gccBuiltins); - - let globalidx = ref 0 in - let doOneGlobal (d: A.definition) = - let s = doDecl true d in - if isNotEmpty s then - E.s (bug "doDecl returns non-empty statement for global"); - (* See if this is one of the globals which we can leave alone. Increment - * globalidx and see if we must leave this alone. *) - if - (match d with - A.DECDEF _ -> true - | A.FUNDEF _ -> true - | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin - (* Create a file where we put the CABS output *) - let temp_cabs_name = "__temp_cabs" in - let temp_cabs = open_out temp_cabs_name in - (* Now print the CABS in there *) - Cprint.commit (); Cprint.flush (); - let old = !Cprint.out in (* Save the old output channel *) - Cprint.out := temp_cabs; - Cprint.print_def d; - Cprint.commit (); Cprint.flush (); - flush !Cprint.out; - Cprint.out := old; - close_out temp_cabs; - (* Now read everythign in *and create a GText from it *) - let temp_cabs = open_in temp_cabs_name in - let buff = Buffer.create 1024 in - Buffer.add_string buff "// Start of CABS form\n"; - Buffer.add_channel buff temp_cabs (in_channel_length temp_cabs); - Buffer.add_string buff "// End of CABS form\n"; - close_in temp_cabs; - (* Try to pop the last thing in the file *) - (match !theFile with - _ :: rest -> theFile := rest - | _ -> ()); - (* Insert in the file a GText *) - cabsPushGlobal (GText(Buffer.contents buff)) - end - in - List.iter doOneGlobal dl; - let globals = ref (popGlobals ()) in - - IH.clear noProtoFunctions; - IH.clear mustTurnIntoDef; - H.clear alreadyDefined; - H.clear compInfoNameEnv; - H.clear enumInfoNameEnv; - H.clear isomorphicStructs; - H.clear staticLocals; - H.clear typedefs; - H.clear env; - H.clear genv; - IH.clear callTempVars; - - if false then ignore (E.log "Cabs2cil converted %d globals\n" !globalidx); - (* We are done *) - { fileName = fname; - globals = !globals; - globinit = None; - globinitcalled = false; - } - - - - diff --git a/cil/src/frontc/cabs2cil.mli b/cil/src/frontc/cabs2cil.mli deleted file mode 100644 index 986f5a2..0000000 --- a/cil/src/frontc/cabs2cil.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -val convFile: Cabs.file -> Cil.file - -(** NDC added command line parameter **) -(* Turn on tranformation that forces correct parameter evaluation order *) -val forceRLArgEval: bool ref - -(* Set this integer to the index of the global to be left in CABS form. Use - * -1 to disable *) -val nocil: int ref - -(* Indicates whether we're allowed to duplicate small chunks of code. *) -val allowDuplication: bool ref diff --git a/cil/src/frontc/cabsvisit.ml b/cil/src/frontc/cabsvisit.ml deleted file mode 100644 index b2f9784..0000000 --- a/cil/src/frontc/cabsvisit.ml +++ /dev/null @@ -1,577 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* cabsvisit.ml *) -(* tree visitor and rewriter for cabs *) - -open Cabs -open Trace -open Pretty -module E = Errormsg - -(* basic interface for a visitor object *) - -(* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) -type 'a visitAction = - SkipChildren (* Do not visit the children. Return - * the node as it is *) - | ChangeTo of 'a (* Replace the expression with the - * given one *) - | DoChildren (* Continue with the children of this - * node. Rebuild the node on return - * if any of the children changes - * (use == test) *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire - * exp is replaced by the first - * paramenter. Then continue with - * the children. On return rebuild - * the node if any of the children - * has changed and then apply the - * function on the node *) - -type nameKind = - NVar (* Variable or function prototype - name *) - | NFun (* A function definition name *) - | NField (* The name of a field *) - | NType (* The name of a type *) - -(* All visit methods are called in preorder! (but you can use - * ChangeDoChildrenPost to change the order) *) -class type cabsVisitor = object - method vexpr: expression -> expression visitAction (* expressions *) - method vinitexpr: init_expression -> init_expression visitAction - method vstmt: statement -> statement list visitAction - method vblock: block -> block visitAction - method vvar: string -> string (* use of a variable - * names *) - method vdef: definition -> definition list visitAction - method vtypespec: typeSpecifier -> typeSpecifier visitAction - method vdecltype: decl_type -> decl_type visitAction - - (* For each declaration we call vname *) - method vname: nameKind -> specifier -> name -> name visitAction - method vspec: specifier -> specifier visitAction (* specifier *) - method vattr: attribute -> attribute list visitAction - - method vEnterScope: unit -> unit - method vExitScope: unit -> unit -end - -let visitorLocation = ref { filename = ""; - lineno = -1; - byteno = -1;} - - (* a default visitor which does nothing to the tree *) -class nopCabsVisitor : cabsVisitor = object - method vexpr (e:expression) = DoChildren - method vinitexpr (e:init_expression) = DoChildren - method vstmt (s: statement) = - visitorLocation := get_statementloc s; - DoChildren - method vblock (b: block) = DoChildren - method vvar (s: string) = s - method vdef (d: definition) = - visitorLocation := get_definitionloc d; - DoChildren - method vtypespec (ts: typeSpecifier) = DoChildren - method vdecltype (dt: decl_type) = DoChildren - method vname k (s:specifier) (n: name) = DoChildren - method vspec (s:specifier) = DoChildren - method vattr (a: attribute) = DoChildren - - method vEnterScope () = () - method vExitScope () = () -end - - (* Map but try not to copy the list unless necessary *) -let rec mapNoCopy (f: 'a -> 'a) = function - [] -> [] - | (i :: resti) as li -> - let i' = f i in - let resti' = mapNoCopy f resti in - if i' != i || resti' != resti then i' :: resti' else li - -let rec mapNoCopyList (f: 'a -> 'a list) = function - [] -> [] - | (i :: resti) as li -> - let il' = f i in - let resti' = mapNoCopyList f resti in - match il' with - [i'] when i' == i && resti' == resti -> li - | _ -> il' @ resti' - -let doVisit (vis: cabsVisitor) - (startvisit: 'a -> 'a visitAction) - (children: cabsVisitor -> 'a -> 'a) - (node: 'a) : 'a = - let action = startvisit node in - match action with - SkipChildren -> node - | ChangeTo node' -> node' - | _ -> - let nodepre = match action with - ChangeDoChildrenPost (node', _) -> node' - | _ -> node - in - let nodepost = children vis nodepre in - match action with - ChangeDoChildrenPost (_, f) -> f nodepost - | _ -> nodepost - -(* A visitor for lists *) -let doVisitList (vis: cabsVisitor) - (startvisit: 'a -> 'a list visitAction) - (children: cabsVisitor -> 'a -> 'a) - (node: 'a) : 'a list = - let action = startvisit node in - match action with - SkipChildren -> [node] - | ChangeTo nodes' -> nodes' - | _ -> - let nodespre = match action with - ChangeDoChildrenPost (nodespre, _) -> nodespre - | _ -> [node] - in - let nodespost = mapNoCopy (children vis) nodespre in - match action with - ChangeDoChildrenPost (_, f) -> f nodespost - | _ -> nodespost - - -let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) = - doVisit vis vis#vtypespec childrenTypeSpecifier ts - -and childrenTypeSpecifier vis ts = - let childrenFieldGroup ((s, nel) as input) = - let s' = visitCabsSpecifier vis s in - let doOneField ((n, eo) as input) = - let n' = visitCabsName vis NField s' n in - let eo' = - match eo with - None -> None - | Some e -> let e' = visitCabsExpression vis e in - if e' != e then Some e' else eo - in - if n' != n || eo' != eo then (n', eo') else input - in - let nel' = mapNoCopy doOneField nel in - if s' != s || nel' != nel then (s', nel') else input - in - match ts with - Tstruct (n, Some fg, extraAttrs) -> - (*(trace "sm" (dprintf "visiting struct %s\n" n));*) - let fg' = mapNoCopy childrenFieldGroup fg in - if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts - | Tunion (n, Some fg, extraAttrs) -> - let fg' = mapNoCopy childrenFieldGroup fg in - if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts - | Tenum (n, Some ei, extraAttrs) -> - let doOneEnumItem ((s, e, loc) as ei) = - let e' = visitCabsExpression vis e in - if e' != e then (s, e', loc) else ei - in - vis#vEnterScope (); - let ei' = mapNoCopy doOneEnumItem ei in - vis#vExitScope(); - if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts - | TtypeofE e -> - let e' = visitCabsExpression vis e in - if e' != e then TtypeofE e' else ts - | TtypeofT (s, dt) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - if s != s' || dt != dt' then TtypeofT (s', dt') else ts - | ts -> ts - -and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem = - match se with - SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se - | SpecCV _ -> se (* cop out *) - | SpecAttr a -> begin - let al' = visitCabsAttribute vis a in - match al' with - [a''] when a'' == a -> se - | [a''] -> SpecAttr a'' - | _ -> E.s (E.unimp "childrenSpecElem: visitCabsAttribute returned a list") - end - | SpecType ts -> - let ts' = visitCabsTypeSpecifier vis ts in - if ts' != ts then SpecType ts' else se - -and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier = - doVisit vis vis#vspec childrenSpec s -and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s - - -and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type = - doVisit vis vis#vdecltype (childrenDeclType isfundef) dt -and childrenDeclType isfundef vis dt = - match dt with - JUSTBASE -> dt - | PARENTYPE (prea, dt1, posta) -> - let prea' = mapNoCopyList (visitCabsAttribute vis) prea in - let dt1' = visitCabsDeclType vis isfundef dt1 in - let posta'= mapNoCopyList (visitCabsAttribute vis) posta in - if prea' != prea || dt1' != dt1 || posta' != posta then - PARENTYPE (prea', dt1', posta') else dt - | ARRAY (dt1, al, e) -> - let dt1' = visitCabsDeclType vis isfundef dt1 in - let al' = mapNoCopy (childrenAttribute vis) al in - let e'= visitCabsExpression vis e in - if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt - | PTR (al, dt1) -> - let al' = mapNoCopy (childrenAttribute vis) al in - let dt1' = visitCabsDeclType vis isfundef dt1 in - if al' != al || dt1' != dt1 then PTR(al', dt1') else dt - | PROTO (dt1, snl, b) -> - (* Do not propagate isfundef further *) - let dt1' = visitCabsDeclType vis false dt1 in - let _ = vis#vEnterScope () in - let snl' = mapNoCopy (childrenSingleName vis NVar) snl in - (* Exit the scope only if not in a function definition *) - let _ = if not isfundef then vis#vExitScope () in - if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt - - -and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) = - let s' = visitCabsSpecifier vis s in - let nl' = mapNoCopy (visitCabsName vis kind s') nl in - if s' != s || nl' != nl then (s', nl') else input - - -and childrenInitNameGroup vis ((s, inl) as input) = - let s' = visitCabsSpecifier vis s in - let inl' = mapNoCopy (childrenInitName vis s') inl in - if s' != s || inl' != inl then (s', inl') else input - -and visitCabsName vis (k: nameKind) (s: specifier) - (n: name) : name = - doVisit vis (vis#vname k s) (childrenName s k) n -and childrenName (s: specifier) (k: nameKind) vis (n: name) : name = - let (sn, dt, al, loc) = n in - let dt' = visitCabsDeclType vis (k = NFun) dt in - let al' = mapNoCopy (childrenAttribute vis) al in - if dt' != dt || al' != al then (sn, dt', al', loc) else n - -and childrenInitName vis (s: specifier) (inn: init_name) : init_name = - let (n, ie) = inn in - let n' = visitCabsName vis NVar s n in - let ie' = visitCabsInitExpression vis ie in - if n' != n || ie' != ie then (n', ie') else inn - -and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name = - let s, n = sn in - let s' = visitCabsSpecifier vis s in - let n' = visitCabsName vis k s' n in - if s' != s || n' != n then (s', n') else sn - -and visitCabsDefinition vis (d: definition) : definition list = - doVisitList vis vis#vdef childrenDefinition d -and childrenDefinition vis d = - match d with - FUNDEF (sn, b, l, lend) -> - let sn' = childrenSingleName vis NFun sn in - let b' = visitCabsBlock vis b in - (* End the scope that was started by childrenFunctionName *) - vis#vExitScope (); - if sn' != sn || b' != b then FUNDEF (sn', b', l, lend) else d - - | DECDEF ((s, inl), l) -> - let s' = visitCabsSpecifier vis s in - let inl' = mapNoCopy (childrenInitName vis s') inl in - if s' != s || inl' != inl then DECDEF ((s', inl'), l) else d - | TYPEDEF (ng, l) -> - let ng' = childrenNameGroup vis NType ng in - if ng' != ng then TYPEDEF (ng', l) else d - | ONLYTYPEDEF (s, l) -> - let s' = visitCabsSpecifier vis s in - if s' != s then ONLYTYPEDEF (s', l) else d - | GLOBASM _ -> d - | PRAGMA (e, l) -> - let e' = visitCabsExpression vis e in - if e' != e then PRAGMA (e', l) else d - | LINKAGE (n, l, dl) -> - let dl' = mapNoCopyList (visitCabsDefinition vis) dl in - if dl' != dl then LINKAGE (n, l, dl') else d - - | TRANSFORMER _ -> d - | EXPRTRANSFORMER _ -> d - -and visitCabsBlock vis (b: block) : block = - doVisit vis vis#vblock childrenBlock b - -and childrenBlock vis (b: block) : block = - let _ = vis#vEnterScope () in - let battrs' = mapNoCopyList (visitCabsAttribute vis) b.battrs in - let bstmts' = mapNoCopyList (visitCabsStatement vis) b.bstmts in - let _ = vis#vExitScope () in - if battrs' != b.battrs || bstmts' != b.bstmts then - { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' } - else - b - -and visitCabsStatement vis (s: statement) : statement list = - doVisitList vis vis#vstmt childrenStatement s -and childrenStatement vis s = - let ve e = visitCabsExpression vis e in - let vs l s = - match visitCabsStatement vis s with - [s'] -> s' - | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l) - in - match s with - NOP _ -> s - | COMPUTATION (e, l) -> - let e' = ve e in - if e' != e then COMPUTATION (e', l) else s - | BLOCK (b, l) -> - let b' = visitCabsBlock vis b in - if b' != b then BLOCK (b', l) else s - | SEQUENCE (s1, s2, l) -> - let s1' = vs l s1 in - let s2' = vs l s2 in - if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s - | IF (e, s1, s2, l) -> - let e' = ve e in - let s1' = vs l s1 in - let s2' = vs l s2 in - if e' != e || s1' != s1 || s2' != s2 then IF (e', s1', s2', l) else s - | WHILE (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then WHILE (e', s1', l) else s - | DOWHILE (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then DOWHILE (e', s1', l) else s - | FOR (fc1, e2, e3, s4, l) -> - let _ = vis#vEnterScope () in - let fc1' = - match fc1 with - FC_EXP e1 -> - let e1' = ve e1 in - if e1' != e1 then FC_EXP e1' else fc1 - | FC_DECL d1 -> - let d1' = - match visitCabsDefinition vis d1 with - [d1'] -> d1' - | _ -> E.s (E.unimp "visitCabs: for can have only one definition") - in - if d1' != d1 then FC_DECL d1' else fc1 - in - let e2' = ve e2 in - let e3' = ve e3 in - let s4' = vs l s4 in - let _ = vis#vExitScope () in - if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4 - then FOR (fc1', e2', e3', s4', l) else s - | BREAK _ | CONTINUE _ | GOTO _ -> s - | RETURN (e, l) -> - let e' = ve e in - if e' != e then RETURN (e', l) else s - | SWITCH (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then SWITCH (e', s1', l) else s - | CASE (e, s1, l) -> - let e' = ve e in - let s1' = vs l s1 in - if e' != e || s1' != s1 then CASE (e', s1', l) else s - | CASERANGE (e1, e2, s3, l) -> - let e1' = ve e1 in - let e2' = ve e2 in - let s3' = vs l s3 in - if e1' != e1 || e2' != e2 || s3' != s3 then - CASERANGE (e1', e2', s3', l) else s - | DEFAULT (s1, l) -> - let s1' = vs l s1 in - if s1' != s1 then DEFAULT (s1', l) else s - | LABEL (n, s1, l) -> - let s1' = vs l s1 in - if s1' != s1 then LABEL (n, s1', l) else s - | COMPGOTO (e, l) -> - let e' = ve e in - if e' != e then COMPGOTO (e', l) else s - | DEFINITION d -> begin - match visitCabsDefinition vis d with - [d'] when d' == d -> s - | [d'] -> DEFINITION d' - | dl -> let l = get_definitionloc d in - let dl' = List.map (fun d' -> DEFINITION d') dl in - BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l) - end - | ASM (sl, b, details, l) -> - let childrenStringExp ((s, e) as input) = - let e' = ve e in - if e' != e then (s, e') else input - in - let details' = match details with - | None -> details - | Some { aoutputs = outl; ainputs = inl; aclobbers = clobs } -> - let outl' = mapNoCopy childrenStringExp outl in - let inl' = mapNoCopy childrenStringExp inl in - if outl' == outl && inl' == inl then - details - else - Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs } - in - if details' != details then - ASM (sl, b, details', l) else s - | TRY_FINALLY (b1, b2, l) -> - let b1' = visitCabsBlock vis b1 in - let b2' = visitCabsBlock vis b2 in - if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s - | TRY_EXCEPT (b1, e, b2, l) -> - let b1' = visitCabsBlock vis b1 in - let e' = visitCabsExpression vis e in - let b2' = visitCabsBlock vis b2 in - if b1' != b1 || e' != e || b2' != b2 then TRY_EXCEPT(b1', e', b2', l) else s - - -and visitCabsExpression vis (e: expression) : expression = - doVisit vis vis#vexpr childrenExpression e -and childrenExpression vis e = - let ve e = visitCabsExpression vis e in - match e with - NOTHING | LABELADDR _ -> e - | UNARY (uo, e1) -> - let e1' = ve e1 in - if e1' != e1 then UNARY (uo, e1') else e - | BINARY (bo, e1, e2) -> - let e1' = ve e1 in - let e2' = ve e2 in - if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e - | QUESTION (e1, e2, e3) -> - let e1' = ve e1 in - let e2' = ve e2 in - let e3' = ve e3 in - if e1' != e1 || e2' != e2 || e3' != e3 then - QUESTION (e1', e2', e3') else e - | CAST ((s, dt), ie) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - let ie' = visitCabsInitExpression vis ie in - if s' != s || dt' != dt || ie' != ie then CAST ((s', dt'), ie') else e - | CALL (f, el) -> - let f' = ve f in - let el' = mapNoCopy ve el in - if f' != f || el' != el then CALL (f', el') else e - | COMMA el -> - let el' = mapNoCopy ve el in - if el' != el then COMMA (el') else e - | CONSTANT _ -> e - | VARIABLE s -> - let s' = vis#vvar s in - if s' != s then VARIABLE s' else e - | EXPR_SIZEOF (e1) -> - let e1' = ve e1 in - if e1' != e1 then EXPR_SIZEOF (e1') else e - | TYPE_SIZEOF (s, dt) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - if s' != s || dt' != dt then TYPE_SIZEOF (s' ,dt') else e - | EXPR_ALIGNOF (e1) -> - let e1' = ve e1 in - if e1' != e1 then EXPR_ALIGNOF (e1') else e - | TYPE_ALIGNOF (s, dt) -> - let s' = visitCabsSpecifier vis s in - let dt' = visitCabsDeclType vis false dt in - if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e - | INDEX (e1, e2) -> - let e1' = ve e1 in - let e2' = ve e2 in - if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e - | MEMBEROF (e1, n) -> - let e1' = ve e1 in - if e1' != e1 then MEMBEROF (e1', n) else e - | MEMBEROFPTR (e1, n) -> - let e1' = ve e1 in - if e1' != e1 then MEMBEROFPTR (e1', n) else e - | GNU_BODY b -> - let b' = visitCabsBlock vis b in - if b' != b then GNU_BODY b' else e - | EXPR_PATTERN _ -> e - -and visitCabsInitExpression vis (ie: init_expression) : init_expression = - doVisit vis vis#vinitexpr childrenInitExpression ie -and childrenInitExpression vis ie = - let rec childrenInitWhat iw = - match iw with - NEXT_INIT -> iw - | INFIELD_INIT (n, iw1) -> - let iw1' = childrenInitWhat iw1 in - if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw - | ATINDEX_INIT (e, iw1) -> - let e' = visitCabsExpression vis e in - let iw1' = childrenInitWhat iw1 in - if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw - | ATINDEXRANGE_INIT (e1, e2) -> - let e1' = visitCabsExpression vis e1 in - let e2' = visitCabsExpression vis e2 in - if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1, e2) else iw - in - match ie with - NO_INIT -> ie - | SINGLE_INIT e -> - let e' = visitCabsExpression vis e in - if e' != e then SINGLE_INIT e' else ie - | COMPOUND_INIT il -> - let childrenOne ((iw, ie) as input) = - let iw' = childrenInitWhat iw in - let ie' = visitCabsInitExpression vis ie in - if iw' != iw || ie' != ie then (iw', ie') else input - in - let il' = mapNoCopy childrenOne il in - if il' != il then COMPOUND_INIT il' else ie - - -and visitCabsAttribute vis (a: attribute) : attribute list = - doVisitList vis vis#vattr childrenAttribute a - -and childrenAttribute vis ((n, el) as input) = - let el' = mapNoCopy (visitCabsExpression vis) el in - if el' != el then (n, el') else input - -and visitCabsAttributes vis (al: attribute list) : attribute list = - mapNoCopyList (visitCabsAttribute vis) al - -let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file = - (fname, mapNoCopyList (visitCabsDefinition vis) f) - - (* end of file *) - diff --git a/cil/src/frontc/cabsvisit.mli b/cil/src/frontc/cabsvisit.mli deleted file mode 100644 index d238789..0000000 --- a/cil/src/frontc/cabsvisit.mli +++ /dev/null @@ -1,115 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* cabsvisit.mli *) -(* interface for cabsvisit.ml *) - -(* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) -type 'a visitAction = - SkipChildren (* Do not visit the children. Return - * the node as it is *) - | ChangeTo of 'a (* Replace the expression with the - * given one *) - | DoChildren (* Continue with the children of this - * node. Rebuild the node on return - * if any of the children changes - * (use == test) *) - | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire - * exp is replaced by the first - * paramenter. Then continue with - * the children. On return rebuild - * the node if any of the children - * has changed and then apply the - * function on the node *) - -type nameKind = - NVar (** Variable or function prototype - name *) - | NFun (** Function definition name *) - | NField (** The name of a field *) - | NType (** The name of a type *) - - -(* All visit methods are called in preorder! (but you can use - * ChangeDoChildrenPost to change the order) *) -class type cabsVisitor = object - method vexpr: Cabs.expression -> Cabs.expression visitAction (* expressions *) - method vinitexpr: Cabs.init_expression -> Cabs.init_expression visitAction - method vstmt: Cabs.statement -> Cabs.statement list visitAction - method vblock: Cabs.block -> Cabs.block visitAction - method vvar: string -> string (* use of a variable - * names *) - method vdef: Cabs.definition -> Cabs.definition list visitAction - method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction - method vdecltype: Cabs.decl_type -> Cabs.decl_type visitAction - - (* For each declaration we call vname *) - method vname: nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name visitAction - method vspec: Cabs.specifier -> Cabs.specifier visitAction (* specifier *) - method vattr: Cabs.attribute -> Cabs.attribute list visitAction - - - method vEnterScope: unit -> unit - method vExitScope: unit -> unit -end - - -class nopCabsVisitor: cabsVisitor - - -val visitCabsTypeSpecifier: cabsVisitor -> - Cabs.typeSpecifier -> Cabs.typeSpecifier -val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier - -(** Visits a decl_type. The bool argument is saying whether we are ina - * function definition and thus the scope in a PROTO should extend until the - * end of the function *) -val visitCabsDeclType: cabsVisitor -> bool -> Cabs.decl_type -> Cabs.decl_type -val visitCabsDefinition: cabsVisitor -> Cabs.definition -> Cabs.definition list -val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block -val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list -val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression -val visitCabsAttributes: cabsVisitor -> Cabs.attribute list - -> Cabs.attribute list -val visitCabsName: cabsVisitor -> nameKind - -> Cabs.specifier -> Cabs.name -> Cabs.name -val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file - - - -(** Set by the visitor to the current location *) -val visitorLocation: Cabs.cabsloc ref diff --git a/cil/src/frontc/clexer.mli b/cil/src/frontc/clexer.mli deleted file mode 100644 index 01acfd0..0000000 --- a/cil/src/frontc/clexer.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* This interface is generated manually. The corresponding .ml file is - * generated automatically and is placed in ../obj/clexer.ml. The reason we - * want this interface is to avoid confusing make with freshly generated - * interface files *) - - -val init: filename:string -> Lexing.lexbuf -val finish: unit -> unit - -(* This is the main parser function *) -val initial: Lexing.lexbuf -> Cparser.token - - -val push_context: unit -> unit (* Start a context *) -val add_type: string -> unit (* Add a new string as a type name *) -val add_identifier: string -> unit (* Add a new string as a variable name *) -val pop_context: unit -> unit (* Remove all names added in this context *) diff --git a/cil/src/frontc/clexer.mll b/cil/src/frontc/clexer.mll deleted file mode 100644 index 41c8692..0000000 --- a/cil/src/frontc/clexer.mll +++ /dev/null @@ -1,666 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(* FrontC -- lexical analyzer -** -** 1.0 3.22.99 Hugues Cassé First version. -** 2.0 George Necula 12/12/00: Many extensions -*) -{ -open Cparser -open Pretty -exception Eof -exception InternalError of string -module E = Errormsg -module H = Hashtbl - -let matchingParsOpen = ref 0 - -let currentLoc () = - let l, f, c = E.getPosition () in - { Cabs.lineno = l; - Cabs.filename = f; - Cabs.byteno = c;} - -(* string -> unit *) -let addComment c = - let l = currentLoc() in - let i = GrowArray.max_init_index Cabs.commentsGA in - GrowArray.setg Cabs.commentsGA (i+1) (l,c,false) - -let int64_to_char value = - if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then - begin - let msg = Printf.sprintf "clexer:intlist_to_string: character 0x%Lx too big" value in - E.parse_error msg; - end - else - Char.chr (Int64.to_int value) - -(* takes a not-nul-terminated list, and converts it to a string. *) -let rec intlist_to_string (str: int64 list):string = - match str with - [] -> "" (* add nul-termination *) - | value::rest -> - let this_char = int64_to_char value in - (String.make 1 this_char) ^ (intlist_to_string rest) - -(* Some debugging support for line numbers *) -let dbgToken (t: token) = - if false then begin - ignore (E.log "%a" insert - (match t with - IDENT (n, l) -> dprintf "IDENT(%s,%d)\n" n l.Cabs.lineno - | LBRACE l -> dprintf "LBRACE(%d)\n" l.Cabs.lineno - | RBRACE l -> dprintf "RBRACE(%d)\n" l.Cabs.lineno - | IF l -> dprintf "IF(%d)\n" l.Cabs.lineno - | SWITCH l -> dprintf "SWITCH(%d)\n" l.Cabs.lineno - | RETURN l -> dprintf "RETURN(%d)\n" l.Cabs.lineno - | _ -> nil)); - t - end else - t - - -(* -** Keyword hashtable -*) -let lexicon = H.create 211 -let init_lexicon _ = - H.clear lexicon; - List.iter - (fun (key, builder) -> H.add lexicon key builder) - [ ("auto", fun loc -> AUTO loc); - ("const", fun loc -> CONST loc); - ("__const", fun loc -> CONST loc); - ("__const__", fun loc -> CONST loc); - ("static", fun loc -> STATIC loc); - ("extern", fun loc -> EXTERN loc); - ("long", fun loc -> LONG loc); - ("short", fun loc -> SHORT loc); - ("register", fun loc -> REGISTER loc); - ("signed", fun loc -> SIGNED loc); - ("__signed", fun loc -> SIGNED loc); - ("unsigned", fun loc -> UNSIGNED loc); - ("volatile", fun loc -> VOLATILE loc); - ("__volatile", fun loc -> VOLATILE loc); - (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile - * are accepted GCC-isms *) - ("char", fun loc -> CHAR loc); - ("int", fun loc -> INT loc); - ("float", fun loc -> FLOAT loc); - ("double", fun loc -> DOUBLE loc); - ("void", fun loc -> VOID loc); - ("enum", fun loc -> ENUM loc); - ("struct", fun loc -> STRUCT loc); - ("typedef", fun loc -> TYPEDEF loc); - ("union", fun loc -> UNION loc); - ("break", fun loc -> BREAK loc); - ("continue", fun loc -> CONTINUE loc); - ("goto", fun loc -> GOTO loc); - ("return", fun loc -> dbgToken (RETURN loc)); - ("switch", fun loc -> dbgToken (SWITCH loc)); - ("case", fun loc -> CASE loc); - ("default", fun loc -> DEFAULT loc); - ("while", fun loc -> WHILE loc); - ("do", fun loc -> DO loc); - ("for", fun loc -> FOR loc); - ("if", fun loc -> dbgToken (IF loc)); - ("else", fun _ -> ELSE); - (*** Implementation specific keywords ***) - ("__signed__", fun loc -> SIGNED loc); - ("__inline__", fun loc -> INLINE loc); - ("inline", fun loc -> INLINE loc); - ("__inline", fun loc -> INLINE loc); - ("_inline", fun loc -> INLINE loc); - ("__attribute__", fun loc -> ATTRIBUTE loc); - ("__attribute", fun loc -> ATTRIBUTE loc); -(* - ("__attribute_used__", fun loc -> ATTRIBUTE_USED loc); -*) - ("__blockattribute__", fun _ -> BLOCKATTRIBUTE); - ("__blockattribute", fun _ -> BLOCKATTRIBUTE); - ("__asm__", fun loc -> ASM loc); - ("asm", fun loc -> ASM loc); - ("__typeof__", fun loc -> TYPEOF loc); - ("__typeof", fun loc -> TYPEOF loc); - ("typeof", fun loc -> TYPEOF loc); - ("__alignof", fun loc -> ALIGNOF loc); - ("__alignof__", fun loc -> ALIGNOF loc); - ("__volatile__", fun loc -> VOLATILE loc); - ("__volatile", fun loc -> VOLATILE loc); - - ("__FUNCTION__", fun loc -> FUNCTION__ loc); - ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *) - ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc); - ("__label__", fun _ -> LABEL__); - (*** weimer: GCC arcana ***) - ("__restrict", fun loc -> RESTRICT loc); - ("restrict", fun loc -> RESTRICT loc); -(* ("__extension__", EXTENSION); *) - (**** MS VC ***) - ("__int64", fun _ -> INT64 (currentLoc ())); - ("__int32", fun loc -> INT loc); - ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ())); - ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ())); - ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ())); - ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ())); - ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ())); - ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ())); - ("__w64", fun _ -> MSATTR("__w64", currentLoc ())); - ("__declspec", fun loc -> DECLSPEC loc); - ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline - * into inline *) - ("__try", fun loc -> TRY loc); - ("__except", fun loc -> EXCEPT loc); - ("__finally", fun loc -> FINALLY loc); - (* weimer: some files produced by 'GCC -E' expect this type to be - * defined *) - ("__builtin_va_list", - fun _ -> NAMED_TYPE ("__builtin_va_list", currentLoc ())); - ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc); - ("__builtin_types_compatible_p", fun loc -> BUILTIN_TYPES_COMPAT loc); - ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc); - (* On some versions of GCC __thread is a regular identifier *) - ("__thread", fun loc -> - if Machdep.__thread_is_keyword then - THREAD loc - else - IDENT ("__thread", loc)); - ] - -(* Mark an identifier as a type name. The old mapping is preserved and will - * be reinstated when we exit this context *) -let add_type name = - (* ignore (print_string ("adding type name " ^ name ^ "\n")); *) - H.add lexicon name (fun loc -> NAMED_TYPE (name, loc)) - -let context : string list list ref = ref [] - -let push_context _ = context := []::!context - -let pop_context _ = - match !context with - [] -> raise (InternalError "Empty context stack") - | con::sub -> - (context := sub; - List.iter (fun name -> - (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *) - H.remove lexicon name) con) - -(* Mark an identifier as a variable name. The old mapping is preserved and - * will be reinstated when we exit this context *) -let add_identifier name = - match !context with - [] -> () (* Just ignore raise (InternalError "Empty context stack") *) - | con::sub -> - (context := (name::con)::sub; - (* print_string ("adding IDENT for " ^ name ^ "\n"); *) - H.add lexicon name (fun loc -> - dbgToken (IDENT (name, loc)))) - - -(* -** Useful primitives -*) -let scan_ident id = - let here = currentLoc () in - try (H.find lexicon id) here - (* default to variable name, as opposed to type *) - with Not_found -> dbgToken (IDENT (id, here)) - - -(* -** Buffer processor -*) - - -let init ~(filename: string) : Lexing.lexbuf = - init_lexicon (); - (* Inititialize the pointer in Errormsg *) - Lexerhack.add_type := add_type; - Lexerhack.push_context := push_context; - Lexerhack.pop_context := pop_context; - Lexerhack.add_identifier := add_identifier; - E.startParsing filename - - -let finish () = - E.finishParsing () - -(*** Error handling ***) -let error msg = - E.parse_error msg - - -(*** escape character management ***) -let scan_escape (char: char) : int64 = - let result = match char with - 'n' -> '\n' - | 'r' -> '\r' - | 't' -> '\t' - | 'b' -> '\b' - | 'f' -> '\012' (* ASCII code 12 *) - | 'v' -> '\011' (* ASCII code 11 *) - | 'a' -> '\007' (* ASCII code 7 *) - | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *) - | '\'' -> '\'' - | '"'-> '"' (* '"' *) - | '?' -> '?' - | '(' when not !Cprint.msvcMode -> '(' - | '{' when not !Cprint.msvcMode -> '{' - | '[' when not !Cprint.msvcMode -> '[' - | '%' when not !Cprint.msvcMode -> '%' - | '\\' -> '\\' - | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other)) - in - Int64.of_int (Char.code result) - -let scan_hex_escape str = - let radix = Int64.of_int 16 in - let the_value = ref Int64.zero in - (* start at character 2 to skip the \x *) - for i = 2 to (String.length str) - 1 do - let thisDigit = Cabs.valueOfDigit (String.get str i) in - (* the_value := !the_value * 16 + thisDigit *) - the_value := Int64.add (Int64.mul !the_value radix) thisDigit - done; - !the_value - -let scan_oct_escape str = - let radix = Int64.of_int 8 in - let the_value = ref Int64.zero in - (* start at character 1 to skip the \x *) - for i = 1 to (String.length str) - 1 do - let thisDigit = Cabs.valueOfDigit (String.get str i) in - (* the_value := !the_value * 8 + thisDigit *) - the_value := Int64.add (Int64.mul !the_value radix) thisDigit - done; - !the_value - -let lex_hex_escape remainder lexbuf = - let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in - prefix :: remainder lexbuf - -let lex_oct_escape remainder lexbuf = - let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in - prefix :: remainder lexbuf - -let lex_simple_escape remainder lexbuf = - let lexchar = Lexing.lexeme_char lexbuf 1 in - let prefix = scan_escape lexchar in - prefix :: remainder lexbuf - -let lex_unescaped remainder lexbuf = - let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in - prefix :: remainder lexbuf - -let lex_comment remainder lexbuf = - let ch = Lexing.lexeme_char lexbuf 0 in - let prefix = Int64.of_int (Char.code ch) in - if ch = '\n' then E.newline(); - prefix :: remainder lexbuf - -let make_char (i:int64):char = - let min_val = Int64.zero in - let max_val = Int64.of_int 255 in - (* if i < 0 || i > 255 then error*) - if compare i min_val < 0 || compare i max_val > 0 then begin - let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in - error msg - end; - Char.chr (Int64.to_int i) - - -(* ISO standard locale-specific function to convert a wide character - * into a sequence of normal characters. Here we work on strings. - * We convert L"Hi" to "H\000i\000" - matth: this seems unused. -let wbtowc wstr = - let len = String.length wstr in - let dest = String.make (len * 2) '\000' in - for i = 0 to len-1 do - dest.[i*2] <- wstr.[i] ; - done ; - dest -*) - -(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } - matth: this seems unused. -let wstr_to_warray wstr = - let len = String.length wstr in - let res = ref "{ " in - for i = 0 to len-1 do - res := !res ^ (Printf.sprintf "L'%c', " wstr.[i]) - done ; - res := !res ^ "}" ; - !res -*) - -(* Pragmas get explicit end-of-line tokens. - * Elsewhere they are silently discarded as whitespace. *) -let pragmaLine = ref false - -} - -let decdigit = ['0'-'9'] -let octdigit = ['0'-'7'] -let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] -let letter = ['a'- 'z' 'A'-'Z'] - - -let usuffix = ['u' 'U'] -let lsuffix = "l"|"L"|"ll"|"LL" -let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix - | usuffix ? "i64" - - -let hexprefix = '0' ['x' 'X'] - -let intnum = decdigit+ intsuffix? -let octnum = '0' octdigit+ intsuffix? -let hexnum = hexprefix hexdigit+ intsuffix? - -let exponent = ['e' 'E']['+' '-']? decdigit+ -let fraction = '.' decdigit+ -let decfloat = (intnum? fraction) - |(intnum exponent) - |(intnum? fraction exponent) - | (intnum '.') - | (intnum '.' exponent) - -let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+ -let binexponent = ['p' 'P'] ['+' '-']? decdigit+ -let hexfloat = hexprefix hexfraction binexponent - | hexprefix hexdigit+ binexponent - -let floatsuffix = ['f' 'F' 'l' 'L'] -let floatnum = (decfloat | hexfloat) floatsuffix? - -let ident = (letter|'_')(letter|decdigit|'_'|'$')* -let blank = [' ' '\t' '\012' '\r']+ -let escape = '\\' _ -let hex_escape = '\\' ['x' 'X'] hexdigit+ -let oct_escape = '\\' octdigit octdigit? octdigit? - -(* Pragmas that are not parsed by CIL. We lex them as PRAGMA_LINE tokens *) - -let no_parse_pragma = - "warning" | "GCC" - (* Solaris-style pragmas: *) - | "ident" | "section" | "option" | "asm" | "use_section" | "weak" - | "redefine_extname" - | "TCS_align" - (* Added by XL *) - | "global_register" - -rule initial = - parse "/*" { let il = comment lexbuf in - let sl = intlist_to_string il in - addComment sl; - initial lexbuf} -| "//" { let il = onelinecomment lexbuf in - let sl = intlist_to_string il in - addComment sl; - E.newline(); - initial lexbuf - } -| blank {initial lexbuf} -| '\n' { E.newline (); - if !pragmaLine then - begin - pragmaLine := false; - PRAGMA_EOL - end - else - initial lexbuf } -| '\\' '\r' * '\n' { - E.newline (); - initial lexbuf - } -| '#' { hash lexbuf} -| "_Pragma" { PRAGMA (currentLoc ()) } -| '\'' { CST_CHAR (chr lexbuf, currentLoc ())} -| "L'" { CST_WCHAR (chr lexbuf, currentLoc ()) } -| '"' { (* '"' *) -(* matth: BUG: this could be either a regular string or a wide string. - * e.g. if it's the "world" in - * L"Hello, " "world" - * then it should be treated as wide even though there's no L immediately - * preceding it. See test/small1/wchar5.c for a failure case. *) - try CST_STRING (str lexbuf, currentLoc ()) - with e -> - raise (InternalError - ("str: " ^ - Printexc.to_string e))} -| "L\"" { (* weimer: wchar_t string literal *) - try CST_WSTRING(str lexbuf, currentLoc ()) - with e -> - raise (InternalError - ("wide string: " ^ - Printexc.to_string e))} -| floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())} -| hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} -| octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} -| intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} -| "!quit!" {EOF} -| "..." {ELLIPSIS} -| "+=" {PLUS_EQ} -| "-=" {MINUS_EQ} -| "*=" {STAR_EQ} -| "/=" {SLASH_EQ} -| "%=" {PERCENT_EQ} -| "|=" {PIPE_EQ} -| "&=" {AND_EQ} -| "^=" {CIRC_EQ} -| "<<=" {INF_INF_EQ} -| ">>=" {SUP_SUP_EQ} -| "<<" {INF_INF} -| ">>" {SUP_SUP} -| "==" {EQ_EQ} -| "!=" {EXCLAM_EQ} -| "<=" {INF_EQ} -| ">=" {SUP_EQ} -| "=" {EQ} -| "<" {INF} -| ">" {SUP} -| "++" {PLUS_PLUS (currentLoc ())} -| "--" {MINUS_MINUS (currentLoc ())} -| "->" {ARROW} -| '+' {PLUS (currentLoc ())} -| '-' {MINUS (currentLoc ())} -| '*' {STAR (currentLoc ())} -| '/' {SLASH} -| '%' {PERCENT} -| '!' {EXCLAM (currentLoc ())} -| "&&" {AND_AND (currentLoc ())} -| "||" {PIPE_PIPE} -| '&' {AND (currentLoc ())} -| '|' {PIPE} -| '^' {CIRC} -| '?' {QUEST} -| ':' {COLON} -| '~' {TILDE (currentLoc ())} - -| '{' {dbgToken (LBRACE (currentLoc ()))} -| '}' {dbgToken (RBRACE (currentLoc ()))} -| '[' {LBRACKET} -| ']' {RBRACKET} -| '(' {dbgToken (LPAREN (currentLoc ())) } -| ')' {RPAREN} -| ';' {dbgToken (SEMICOLON (currentLoc ())) } -| ',' {COMMA} -| '.' {DOT} -| "sizeof" {SIZEOF (currentLoc ())} -| "__asm" { if !Cprint.msvcMode then - MSASM (msasm lexbuf, currentLoc ()) - else (ASM (currentLoc ())) } - -(* If we see __pragma we eat it and the matching parentheses as well *) -| "__pragma" { matchingParsOpen := 0; - let _ = matchingpars lexbuf in - initial lexbuf - } - -(* sm: tree transformation keywords *) -| "@transform" {AT_TRANSFORM (currentLoc ())} -| "@transformExpr" {AT_TRANSFORMEXPR (currentLoc ())} -| "@specifier" {AT_SPECIFIER (currentLoc ())} -| "@expr" {AT_EXPR (currentLoc ())} -| "@name" {AT_NAME} - -(* __extension__ is a black. The parser runs into some conflicts if we let it - * pass *) -| "__extension__" {initial lexbuf } -| ident {scan_ident (Lexing.lexeme lexbuf)} -| eof {EOF} -| _ {E.parse_error "Invalid symbol"} -and comment = - parse - "*/" { [] } -(*| '\n' { E.newline (); lex_unescaped comment lexbuf }*) -| _ { lex_comment comment lexbuf } - - -and onelinecomment = parse - '\n' {[]} -| _ { lex_comment onelinecomment lexbuf } - -and matchingpars = parse - '\n' { E.newline (); matchingpars lexbuf } -| blank { matchingpars lexbuf } -| '(' { incr matchingParsOpen; matchingpars lexbuf } -| ')' { decr matchingParsOpen; - if !matchingParsOpen = 0 then - () - else - matchingpars lexbuf - } -| "/*" { let il = comment lexbuf in - let sl = intlist_to_string il in - addComment sl; - matchingpars lexbuf} -| '"' { (* '"' *) - let _ = str lexbuf in - matchingpars lexbuf - } -| _ { matchingpars lexbuf } - -(* # ... *) -and hash = parse - '\n' { E.newline (); initial lexbuf} -| blank { hash lexbuf} -| intnum { (* We are seeing a line number. This is the number for the - * next line *) - let s = Lexing.lexeme lexbuf in - begin try - E.setCurrentLine (int_of_string s - 1) - with Failure _ -> - E.warn "Bad line number in preprocessed file: %s" s - end; - (* A file name must follow *) - file lexbuf } -| "line" { hash lexbuf } (* MSVC line number info *) - (* For pragmas with irregular syntax, like #pragma warning, - * we parse them as a whole line. *) -| "pragma" blank (no_parse_pragma as pragmaName) - { let here = currentLoc () in - PRAGMA_LINE (pragmaName ^ pragma lexbuf, here) - } -| "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) } -| _ { endline lexbuf} - -and file = parse - '\n' {E.newline (); initial lexbuf} -| blank {file lexbuf} -| '"' [^ '\012' '\t' '"']* '"' { (* '"' *) - let n = Lexing.lexeme lexbuf in - let n1 = String.sub n 1 - ((String.length n) - 2) in - E.setCurrentFile n1; - endline lexbuf} - -| _ {endline lexbuf} - -and endline = parse - '\n' { E.newline (); initial lexbuf} -| eof { EOF } -| _ { endline lexbuf} - -and pragma = parse - '\n' { E.newline (); "" } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (pragma lexbuf) } - -and str = parse - '"' {[]} (* no nul terminiation in CST_STRING '"' *) -| hex_escape {lex_hex_escape str lexbuf} -| oct_escape {lex_oct_escape str lexbuf} -| escape {lex_simple_escape str lexbuf} -| _ {lex_unescaped str lexbuf} - -and chr = parse - '\'' {[]} -| hex_escape {lex_hex_escape chr lexbuf} -| oct_escape {lex_oct_escape chr lexbuf} -| escape {lex_simple_escape chr lexbuf} -| _ {lex_unescaped chr lexbuf} - -and msasm = parse - blank { msasm lexbuf } -| '{' { msasminbrace lexbuf } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (msasmnobrace lexbuf) } - -and msasminbrace = parse - '}' { "" } -| _ { let cur = Lexing.lexeme lexbuf in - cur ^ (msasminbrace lexbuf) } -and msasmnobrace = parse - ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <- - lexbuf.Lexing.lex_curr_pos - 1; - "" } -| "__asm" { lexbuf.Lexing.lex_curr_pos <- - lexbuf.Lexing.lex_curr_pos - 5; - "" } -| _ { let cur = Lexing.lexeme lexbuf in - - cur ^ (msasmnobrace lexbuf) } - -{ - -} diff --git a/cil/src/frontc/cparser.mly b/cil/src/frontc/cparser.mly deleted file mode 100644 index f1e1ef9..0000000 --- a/cil/src/frontc/cparser.mly +++ /dev/null @@ -1,1521 +0,0 @@ -/*(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - **) -(** -** 1.0 3.22.99 Hugues Cassé First version. -** 2.0 George Necula 12/12/00: Practically complete rewrite. -*) -*/ -%{ -open Cabs -module E = Errormsg - -let parse_error msg : unit = (* sm: c++-mode highlight hack: -> ' <- *) - E.parse_error msg - -let print = print_string - -(* unit -> string option *) -(* -let getComments () = - match !comments with - [] -> None - | _ -> - let r = Some(String.concat "\n" (List.rev !comments)) in - comments := []; - r -*) - -let currentLoc () = - let l, f, c = E.getPosition () in - { lineno = l; - filename = f; - byteno = c;} - -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10;} - -(* cabsloc -> cabsloc *) -(* -let handleLoc l = - l.clcomment <- getComments(); - l -*) - -(* -** Expression building -*) -let smooth_expression lst = - match lst with - [] -> NOTHING - | [expr] -> expr - | _ -> COMMA (lst) - - -let currentFunctionName = ref "" - -let announceFunctionName ((n, decl, _, _):name) = - !Lexerhack.add_identifier n; - (* Start a context that includes the parameter names and the whole body. - * Will pop when we finish parsing the function body *) - !Lexerhack.push_context (); - (* Go through all the parameter names and mark them as identifiers *) - let rec findProto = function - PROTO (d, args, _) when isJUSTBASE d -> - List.iter (fun (_, (an, _, _, _)) -> !Lexerhack.add_identifier an) args - - | PROTO (d, _, _) -> findProto d - | PARENTYPE (_, d, _) -> findProto d - | PTR (_, d) -> findProto d - | ARRAY (d, _, _) -> findProto d - | _ -> parse_error "Cannot find the prototype in a function definition"; - raise Parsing.Parse_error - - and isJUSTBASE = function - JUSTBASE -> true - | PARENTYPE (_, d, _) -> isJUSTBASE d - | _ -> false - in - findProto decl; - currentFunctionName := n - - - -let applyPointer (ptspecs: attribute list list) (dt: decl_type) - : decl_type = - (* Outer specification first *) - let rec loop = function - [] -> dt - | attrs :: rest -> PTR(attrs, loop rest) - in - loop ptspecs - -let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition = - if isTypedef specs then begin - (* Tell the lexer about the new type names *) - List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_type n) nl; - TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc) - end else - if nl = [] then - ONLYTYPEDEF (specs, loc) - else begin - (* Tell the lexer about the new variable names *) - List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_identifier n) nl; - DECDEF ((specs, nl), loc) - end - - -let doFunctionDef (loc: cabsloc) - (lend: cabsloc) - (specs: spec_elem list) - (n: name) - (b: block) : definition = - let fname = (specs, n) in - FUNDEF (fname, b, loc, lend) - - -let doOldParDecl (names: string list) - ((pardefs: name_group list), (isva: bool)) - : single_name list * bool = - let findOneName n = - (* Search in pardefs for the definition for this parameter *) - let rec loopGroups = function - [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu)) - | (specs, names) :: restgroups -> - let rec loopNames = function - [] -> loopGroups restgroups - | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn) - | _ :: restnames -> loopNames restnames - in - loopNames names - in - loopGroups pardefs - in - let args = List.map findOneName names in - (args, isva) - -let checkConnective (s : string) : unit = -begin - (* checking this means I could possibly have more connectives, with *) - (* different meaning *) - if (s <> "to") then ( - parse_error "transformer connective must be 'to'"; - raise Parsing.Parse_error - ) - else () -end - -let int64_to_char value = - if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then - begin - let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in - parse_error msg; - raise Parsing.Parse_error - end - else - Char.chr (Int64.to_int value) - -(* takes a not-nul-terminated list, and converts it to a string. *) -let rec intlist_to_string (str: int64 list):string = - match str with - [] -> "" (* add nul-termination *) - | value::rest -> - let this_char = int64_to_char value in - (String.make 1 this_char) ^ (intlist_to_string rest) - -let fst3 (result, _, _) = result -let snd3 (_, result, _) = result -let trd3 (_, _, result) = result - - -(* - transform: __builtin_offsetof(type, member) - into : (size_t) (&(type * ) 0)->member - *) - -let transformOffsetOf (speclist, dtype) member = - let rec addPointer = function - | JUSTBASE -> - PTR([], JUSTBASE) - | PARENTYPE (attrs1, dtype, attrs2) -> - PARENTYPE (attrs1, addPointer dtype, attrs2) - | ARRAY (dtype, attrs, expr) -> - ARRAY (addPointer dtype, attrs, expr) - | PTR (attrs, dtype) -> - PTR (attrs, addPointer dtype) - | PROTO (dtype, names, variadic) -> - PROTO (addPointer dtype, names, variadic) - in - let nullType = (speclist, addPointer dtype) in - let nullExpr = CONSTANT (CONST_INT "0") in - let castExpr = CAST (nullType, SINGLE_INIT nullExpr) in - - let rec replaceBase = function - | VARIABLE field -> - MEMBEROFPTR (castExpr, field) - | MEMBEROF (base, field) -> - MEMBEROF (replaceBase base, field) - | INDEX (base, index) -> - INDEX (replaceBase base, index) - | _ -> - parse_error "malformed offset expression in __builtin_offsetof"; - raise Parsing.Parse_error - in - let memberExpr = replaceBase member in - let addrExpr = UNARY (ADDROF, memberExpr) in - (* slight cheat: hard-coded assumption that size_t == unsigned int *) - let sizeofType = [SpecType Tunsigned], JUSTBASE in - let resultExpr = CAST (sizeofType, SINGLE_INIT addrExpr) in - resultExpr - -%} - -%token IDENT -%token CST_CHAR -%token CST_WCHAR -%token CST_INT -%token CST_FLOAT -%token NAMED_TYPE - -/* Each character is its own list element, and the terminating nul is not - included in this list. */ -%token CST_STRING -%token CST_WSTRING - -%token EOF -%token CHAR INT DOUBLE FLOAT VOID INT64 INT32 -%token ENUM STRUCT TYPEDEF UNION -%token SIGNED UNSIGNED LONG SHORT -%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER -%token THREAD - -%token SIZEOF ALIGNOF - -%token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ -%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ -%token ARROW DOT - -%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ -%token PLUS MINUS STAR -%token SLASH PERCENT -%token TILDE AND -%token PIPE CIRC -%token EXCLAM AND_AND -%token PIPE_PIPE -%token INF_INF SUP_SUP -%token PLUS_PLUS MINUS_MINUS - -%token RPAREN -%token LPAREN RBRACE -%token LBRACE -%token LBRACKET RBRACKET -%token COLON -%token SEMICOLON -%token COMMA ELLIPSIS QUEST - -%token BREAK CONTINUE GOTO RETURN -%token SWITCH CASE DEFAULT -%token WHILE DO FOR -%token IF TRY EXCEPT FINALLY -%token ELSE - -%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ -%token LABEL__ -%token BUILTIN_VA_ARG ATTRIBUTE_USED -%token BUILTIN_VA_LIST -%token BLOCKATTRIBUTE -%token BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF -%token DECLSPEC -%token MSASM MSATTR -%token PRAGMA_LINE -%token PRAGMA -%token PRAGMA_EOL - -/* sm: cabs tree transformation specification keywords */ -%token AT_TRANSFORM AT_TRANSFORMEXPR AT_SPECIFIER AT_EXPR -%token AT_NAME - -/* operator precedence */ -%nonassoc IF -%nonassoc ELSE - - -%left COMMA -%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ - AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ -%right QUEST COLON -%left PIPE_PIPE -%left AND_AND -%left PIPE -%left CIRC -%left AND -%left EQ_EQ EXCLAM_EQ -%left INF SUP INF_EQ SUP_EQ -%left INF_INF SUP_SUP -%left PLUS MINUS -%left STAR SLASH PERCENT CONST RESTRICT VOLATILE -%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF -%left LBRACKET -%left DOT ARROW LPAREN LBRACE -%right NAMED_TYPE /* We'll use this to handle redefinitions of - * NAMED_TYPE as variables */ -%left IDENT - -/* Non-terminals informations */ -%start interpret file -%type file interpret globals - -%type global - - -%type attributes attributes_with_asm asmattr -%type statement -%type constant -%type string_constant -%type expression -%type opt_expression -%type init_expression -%type comma_expression -%type paren_comma_expression -%type arguments -%type bracket_comma_expression -%type string_list -%type wstring_list - -%type initializer -%type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list -%type init_designators init_designators_opt - -%type decl_spec_list -%type type_spec -%type struct_decl_list - - -%type old_proto_decl -%type parameter_decl -%type enumerator -%type enum_list -%type declaration function_def -%type function_def_start -%type type_name -%type block -%type block_element_list -%type local_labels local_label_names -%type old_parameter_list_ne - -%type init_declarator -%type init_declarator_list -%type declarator -%type field_decl -%type <(Cabs.name * expression option) list> field_decl_list -%type direct_decl -%type abs_direct_decl abs_direct_decl_opt -%type abstract_decl - - /* (* Each element is a "* ". *) */ -%type pointer pointer_opt -%type location -%type cvspec -%% - -interpret: - file EOF {$1} -; -file: globals {$1} -; -globals: - /* empty */ { [] } -| global globals { $1 :: $2 } -| SEMICOLON globals { $2 } -; - -location: - /* empty */ { currentLoc () } %prec IDENT - - -/*** Global Definition ***/ -global: -| declaration { $1 } -| function_def { $1 } -/*(* Some C header files ar shared with the C++ compiler and have linkage - * specification *)*/ -| EXTERN string_constant declaration { LINKAGE (fst $2, (*handleLoc*) (snd $2), [ $3 ]) } -| EXTERN string_constant LBRACE globals RBRACE - { LINKAGE (fst $2, (*handleLoc*) (snd $2), $4) } -| ASM LPAREN string_constant RPAREN SEMICOLON - { GLOBASM (fst $3, (*handleLoc*) $1) } -| pragma { $1 } -/* (* Old-style function prototype. This should be somewhere else, like in - * "declaration". For now we keep it at global scope only because in local - * scope it looks too much like a function call *) */ -| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON - { (* Convert pardecl to new style *) - let pardecl, isva = doOldParDecl $3 $5 in - (* Make the function declarator *) - doDeclaration ((*handleLoc*) (snd $1)) [] - [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu), - NO_INIT)] - } -/* (* Old style function prototype, but without any arguments *) */ -| IDENT LPAREN RPAREN SEMICOLON - { (* Make the function declarator *) - doDeclaration ((*handleLoc*)(snd $1)) [] - [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu), - NO_INIT)] - } -/* transformer for a toplevel construct */ -| AT_TRANSFORM LBRACE global RBRACE IDENT/*to*/ LBRACE globals RBRACE { - checkConnective(fst $5); - TRANSFORMER($3, $7, $1) - } -/* transformer for an expression */ -| AT_TRANSFORMEXPR LBRACE expression RBRACE IDENT/*to*/ LBRACE expression RBRACE { - checkConnective(fst $5); - EXPRTRANSFORMER(fst $3, fst $7, $1) - } -| location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) } -; - -id_or_typename: - IDENT {fst $1} -| NAMED_TYPE {fst $1} -| AT_NAME LPAREN IDENT RPAREN { "@name(" ^ fst $3 ^ ")" } /* pattern variable name */ -; - -maybecomma: - /* empty */ { () } -| COMMA { () } -; - -/* *** Expressions *** */ - -primary_expression: /*(* 6.5.1. *)*/ -| IDENT - {VARIABLE (fst $1), snd $1} -| constant - {CONSTANT (fst $1), snd $1} -| paren_comma_expression - {smooth_expression (fst $1), snd $1} -| LPAREN block RPAREN - { GNU_BODY (fst3 $2), $1 } - - /*(* Next is Scott's transformer *)*/ -| AT_EXPR LPAREN IDENT RPAREN /* expression pattern variable */ - { EXPR_PATTERN(fst $3), $1 } -; - -postfix_expression: /*(* 6.5.2 *)*/ -| primary_expression - { $1 } -| postfix_expression bracket_comma_expression - {INDEX (fst $1, smooth_expression $2), snd $1} -| postfix_expression LPAREN arguments RPAREN - {CALL (fst $1, $3), snd $1} -| BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN - { let b, d = $5 in - CALL (VARIABLE "__builtin_va_arg", - [fst $3; TYPE_SIZEOF (b, d)]), $1 } -| BUILTIN_TYPES_COMPAT LPAREN type_name COMMA type_name RPAREN - { let b1,d1 = $3 in - let b2,d2 = $5 in - CALL (VARIABLE "__builtin_types_compatible_p", - [TYPE_SIZEOF(b1,d1); TYPE_SIZEOF(b2,d2)]), $1 } -| BUILTIN_OFFSETOF LPAREN type_name COMMA offsetof_member_designator RPAREN - { transformOffsetOf $3 (fst $5), $1 } -| postfix_expression DOT id_or_typename - {MEMBEROF (fst $1, $3), snd $1} -| postfix_expression ARROW id_or_typename - {MEMBEROFPTR (fst $1, $3), snd $1} -| postfix_expression PLUS_PLUS - {UNARY (POSINCR, fst $1), snd $1} -| postfix_expression MINUS_MINUS - {UNARY (POSDECR, fst $1), snd $1} -/* (* We handle GCC constructor expressions *) */ -| LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE - { CAST($2, COMPOUND_INIT $5), $1 } -; - -offsetof_member_designator: /* GCC extension for __builtin_offsetof */ -| IDENT - { VARIABLE (fst $1), snd $1 } -| offsetof_member_designator DOT IDENT - { MEMBEROF (fst $1, fst $3), snd $1 } -| offsetof_member_designator bracket_comma_expression - { INDEX (fst $1, smooth_expression $2), snd $1 } -; - -unary_expression: /*(* 6.5.3 *)*/ -| postfix_expression - { $1 } -| PLUS_PLUS unary_expression - {UNARY (PREINCR, fst $2), $1} -| MINUS_MINUS unary_expression - {UNARY (PREDECR, fst $2), $1} -| SIZEOF unary_expression - {EXPR_SIZEOF (fst $2), $1} -| SIZEOF LPAREN type_name RPAREN - {let b, d = $3 in TYPE_SIZEOF (b, d), $1} -| ALIGNOF unary_expression - {EXPR_ALIGNOF (fst $2), $1} -| ALIGNOF LPAREN type_name RPAREN - {let b, d = $3 in TYPE_ALIGNOF (b, d), $1} -| PLUS cast_expression - {UNARY (PLUS, fst $2), $1} -| MINUS cast_expression - {UNARY (MINUS, fst $2), $1} -| STAR cast_expression - {UNARY (MEMOF, fst $2), $1} -| AND cast_expression - {UNARY (ADDROF, fst $2), $1} -| EXCLAM cast_expression - {UNARY (NOT, fst $2), $1} -| TILDE cast_expression - {UNARY (BNOT, fst $2), $1} -| AND_AND IDENT { LABELADDR (fst $2), $1 } -; - -cast_expression: /*(* 6.5.4 *)*/ -| unary_expression - { $1 } -| LPAREN type_name RPAREN cast_expression - { CAST($2, SINGLE_INIT (fst $4)), $1 } -; - -multiplicative_expression: /*(* 6.5.5 *)*/ -| cast_expression - { $1 } -| multiplicative_expression STAR cast_expression - {BINARY(MUL, fst $1, fst $3), snd $1} -| multiplicative_expression SLASH cast_expression - {BINARY(DIV, fst $1, fst $3), snd $1} -| multiplicative_expression PERCENT cast_expression - {BINARY(MOD, fst $1, fst $3), snd $1} -; - -additive_expression: /*(* 6.5.6 *)*/ -| multiplicative_expression - { $1 } -| additive_expression PLUS multiplicative_expression - {BINARY(ADD, fst $1, fst $3), snd $1} -| additive_expression MINUS multiplicative_expression - {BINARY(SUB, fst $1, fst $3), snd $1} -; - -shift_expression: /*(* 6.5.7 *)*/ -| additive_expression - { $1 } -| shift_expression INF_INF additive_expression - {BINARY(SHL, fst $1, fst $3), snd $1} -| shift_expression SUP_SUP additive_expression - {BINARY(SHR, fst $1, fst $3), snd $1} -; - - -relational_expression: /*(* 6.5.8 *)*/ -| shift_expression - { $1 } -| relational_expression INF shift_expression - {BINARY(LT, fst $1, fst $3), snd $1} -| relational_expression SUP shift_expression - {BINARY(GT, fst $1, fst $3), snd $1} -| relational_expression INF_EQ shift_expression - {BINARY(LE, fst $1, fst $3), snd $1} -| relational_expression SUP_EQ shift_expression - {BINARY(GE, fst $1, fst $3), snd $1} -; - -equality_expression: /*(* 6.5.9 *)*/ -| relational_expression - { $1 } -| equality_expression EQ_EQ relational_expression - {BINARY(EQ, fst $1, fst $3), snd $1} -| equality_expression EXCLAM_EQ relational_expression - {BINARY(NE, fst $1, fst $3), snd $1} -; - - -bitwise_and_expression: /*(* 6.5.10 *)*/ -| equality_expression - { $1 } -| bitwise_and_expression AND equality_expression - {BINARY(BAND, fst $1, fst $3), snd $1} -; - -bitwise_xor_expression: /*(* 6.5.11 *)*/ -| bitwise_and_expression - { $1 } -| bitwise_xor_expression CIRC bitwise_and_expression - {BINARY(XOR, fst $1, fst $3), snd $1} -; - -bitwise_or_expression: /*(* 6.5.12 *)*/ -| bitwise_xor_expression - { $1 } -| bitwise_or_expression PIPE bitwise_xor_expression - {BINARY(BOR, fst $1, fst $3), snd $1} -; - -logical_and_expression: /*(* 6.5.13 *)*/ -| bitwise_or_expression - { $1 } -| logical_and_expression AND_AND bitwise_or_expression - {BINARY(AND, fst $1, fst $3), snd $1} -; - -logical_or_expression: /*(* 6.5.14 *)*/ -| logical_and_expression - { $1 } -| logical_or_expression PIPE_PIPE logical_and_expression - {BINARY(OR, fst $1, fst $3), snd $1} -; - -conditional_expression: /*(* 6.5.15 *)*/ -| logical_or_expression - { $1 } -| logical_or_expression QUEST opt_expression COLON conditional_expression - {QUESTION (fst $1, $3, fst $5), snd $1} -; - -/*(* The C spec says that left-hand sides of assignment expressions are unary - * expressions. GCC allows cast expressions in there ! *)*/ - -assignment_expression: /*(* 6.5.16 *)*/ -| conditional_expression - { $1 } -| cast_expression EQ assignment_expression - {BINARY(ASSIGN, fst $1, fst $3), snd $1} -| cast_expression PLUS_EQ assignment_expression - {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression MINUS_EQ assignment_expression - {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression STAR_EQ assignment_expression - {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression SLASH_EQ assignment_expression - {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression PERCENT_EQ assignment_expression - {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression AND_EQ assignment_expression - {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression PIPE_EQ assignment_expression - {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression CIRC_EQ assignment_expression - {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression INF_INF_EQ assignment_expression - {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1} -| cast_expression SUP_SUP_EQ assignment_expression - {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1} -; - -expression: /*(* 6.5.17 *)*/ - assignment_expression - { $1 } -; - - -constant: - CST_INT {CONST_INT (fst $1), snd $1} -| CST_FLOAT {CONST_FLOAT (fst $1), snd $1} -| CST_CHAR {CONST_CHAR (fst $1), snd $1} -| CST_WCHAR {CONST_WCHAR (fst $1), snd $1} -| string_constant {CONST_STRING (fst $1), snd $1} -| wstring_list {CONST_WSTRING (fst $1), snd $1} -; - -string_constant: -/* Now that we know this constant isn't part of a wstring, convert it - back to a string for easy viewing. */ - string_list { - let queue, location = $1 in - let buffer = Buffer.create (Queue.length queue) in - Queue.iter - (List.iter - (fun value -> - let char = int64_to_char value in - Buffer.add_char buffer char)) - queue; - Buffer.contents buffer, location - } -; -one_string_constant: -/* Don't concat multiple strings. For asm templates. */ - CST_STRING {intlist_to_string (fst $1) } -; -string_list: - one_string { - let queue = Queue.create () in - Queue.add (fst $1) queue; - queue, snd $1 - } -| string_list one_string { - Queue.add (fst $2) (fst $1); - $1 - } -; - -wstring_list: - CST_WSTRING { $1 } -| wstring_list one_string { (fst $1) @ (fst $2), snd $1 } -| wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 } -/* Only the first string in the list needs an L, so L"a" "b" is the same - * as L"ab" or L"a" L"b". */ - -one_string: - CST_STRING {$1} -| FUNCTION__ {(Cabs.explodeStringToInts - !currentFunctionName), $1} -| PRETTY_FUNCTION__ {(Cabs.explodeStringToInts - !currentFunctionName), $1} -; - -init_expression: - expression { SINGLE_INIT (fst $1) } -| LBRACE initializer_list_opt RBRACE - { COMPOUND_INIT $2} - -initializer_list: /* ISO 6.7.8. Allow a trailing COMMA */ - initializer { [$1] } -| initializer COMMA initializer_list_opt { $1 :: $3 } -; -initializer_list_opt: - /* empty */ { [] } -| initializer_list { $1 } -; -initializer: - init_designators eq_opt init_expression { ($1, $3) } -| gcc_init_designators init_expression { ($1, $2) } -| init_expression { (NEXT_INIT, $1) } -; -eq_opt: - EQ { () } - /*(* GCC allows missing = *)*/ -| /*(* empty *)*/ { () } -; -init_designators: - DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) } -| LBRACKET expression RBRACKET init_designators_opt - { ATINDEX_INIT(fst $2, $4) } -| LBRACKET expression ELLIPSIS expression RBRACKET - { ATINDEXRANGE_INIT(fst $2, fst $4) } -; -init_designators_opt: - /* empty */ { NEXT_INIT } -| init_designators { $1 } -; - -gcc_init_designators: /*(* GCC supports these strange things *)*/ - id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) } -; - -arguments: - /* empty */ { [] } -| comma_expression { fst $1 } -; - -opt_expression: - /* empty */ - {NOTHING} -| comma_expression - {smooth_expression (fst $1)} -; - -comma_expression: - expression {[fst $1], snd $1} -| expression COMMA comma_expression { fst $1 :: fst $3, snd $1 } -| error COMMA comma_expression { $3 } -; - -comma_expression_opt: - /* empty */ { NOTHING } -| comma_expression { smooth_expression (fst $1) } -; - -paren_comma_expression: - LPAREN comma_expression RPAREN { $2 } -| LPAREN error RPAREN { [], $1 } -; - -bracket_comma_expression: - LBRACKET comma_expression RBRACKET { fst $2 } -| LBRACKET error RBRACKET { [] } -; - - -/*** statements ***/ -block: /* ISO 6.8.2 */ - block_begin local_labels block_attrs block_element_list RBRACE - {!Lexerhack.pop_context(); - { blabels = $2; - battrs = $3; - bstmts = $4 }, - $1, $5 - } -| error location RBRACE { { blabels = []; - battrs = []; - bstmts = [] }, - $2, $3 - } -; -block_begin: - LBRACE {!Lexerhack.push_context (); $1} -; - -block_attrs: - /* empty */ { [] } -| BLOCKATTRIBUTE paren_attr_list_ne - { [("__blockattribute__", $2)] } -; - -/* statements and declarations in a block, in any order (for C99 support) */ -block_element_list: - /* empty */ { [] } -| declaration block_element_list { DEFINITION($1) :: $2 } -| statement block_element_list { $1 :: $2 } -/*(* GCC accepts a label at the end of a block *)*/ -| IDENT COLON { [ LABEL (fst $1, NOP (snd $1), - snd $1)] } -| pragma block_element_list { $2 } -; - -local_labels: - /* empty */ { [] } -| LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 } -; -local_label_names: - IDENT { [ fst $1 ] } -| IDENT COMMA local_label_names { fst $1 :: $3 } -; - - - -statement: - SEMICOLON {NOP ((*handleLoc*) $1) } -| comma_expression SEMICOLON - {COMPUTATION (smooth_expression (fst $1), (*handleLoc*)(snd $1))} -| block {BLOCK (fst3 $1, (*handleLoc*)(snd3 $1))} -| IF paren_comma_expression statement %prec IF - {IF (smooth_expression (fst $2), $3, NOP $1, $1)} -| IF paren_comma_expression statement ELSE statement - {IF (smooth_expression (fst $2), $3, $5, (*handleLoc*) $1)} -| SWITCH paren_comma_expression statement - {SWITCH (smooth_expression (fst $2), $3, (*handleLoc*) $1)} -| WHILE paren_comma_expression statement - {WHILE (smooth_expression (fst $2), $3, (*handleLoc*) $1)} -| DO statement WHILE paren_comma_expression SEMICOLON - {DOWHILE (smooth_expression (fst $4), $2, (*handleLoc*) $1)} -| FOR LPAREN for_clause opt_expression - SEMICOLON opt_expression RPAREN statement - {FOR ($3, $4, $6, $8, (*handleLoc*) $1)} -| IDENT COLON statement - {LABEL (fst $1, $3, (*handleLoc*) (snd $1))} -| CASE expression COLON statement - {CASE (fst $2, $4, (*handleLoc*) $1)} -| CASE expression ELLIPSIS expression COLON statement - {CASERANGE (fst $2, fst $4, $6, (*handleLoc*) $1)} -| DEFAULT COLON - {DEFAULT (NOP $1, (*handleLoc*) $1)} -| RETURN SEMICOLON {RETURN (NOTHING, (*handleLoc*) $1)} -| RETURN comma_expression SEMICOLON - {RETURN (smooth_expression (fst $2), (*handleLoc*) $1)} -| BREAK SEMICOLON {BREAK ((*handleLoc*) $1)} -| CONTINUE SEMICOLON {CONTINUE ((*handleLoc*) $1)} -| GOTO IDENT SEMICOLON - {GOTO (fst $2, (*handleLoc*) $1)} -| GOTO STAR comma_expression SEMICOLON - { COMPGOTO (smooth_expression (fst $3), (*handleLoc*) $1) } -| ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON - { ASM ($2, $4, $5, (*handleLoc*) $1) } -| MSASM { ASM ([], [fst $1], None, (*handleLoc*)(snd $1))} -| TRY block EXCEPT paren_comma_expression block - { let b, _, _ = $2 in - let h, _, _ = $5 in - if not !Cprint.msvcMode then - parse_error "try/except in GCC code"; - TRY_EXCEPT (b, COMMA (fst $4), h, (*handleLoc*) $1) } -| TRY block FINALLY block - { let b, _, _ = $2 in - let h, _, _ = $4 in - if not !Cprint.msvcMode then - parse_error "try/finally in GCC code"; - TRY_FINALLY (b, h, (*handleLoc*) $1) } - -| error location SEMICOLON { (NOP $2)} -; - - -for_clause: - opt_expression SEMICOLON { FC_EXP $1 } -| declaration { FC_DECL $1 } -; - -declaration: /* ISO 6.7.*/ - decl_spec_list init_declarator_list SEMICOLON - { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) $2 } -| decl_spec_list SEMICOLON - { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) [] } -; -init_declarator_list: /* ISO 6.7 */ - init_declarator { [$1] } -| init_declarator COMMA init_declarator_list { $1 :: $3 } - -; -init_declarator: /* ISO 6.7 */ - declarator { ($1, NO_INIT) } -| declarator EQ init_expression - { ($1, $3) } -; - -decl_spec_list: /* ISO 6.7 */ - /* ISO 6.7.1 */ -| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 } -| EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 } -| STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 } -| AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 } -| REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1} - /* ISO 6.7.2 */ -| type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 } - /* ISO 6.7.4 */ -| INLINE decl_spec_list_opt { SpecInline :: $2, $1 } -| cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 } -| attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 } -/* specifier pattern variable (must be last in spec list) */ -| AT_SPECIFIER LPAREN IDENT RPAREN { [ SpecPattern(fst $3) ], $1 } -; -/* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare - * NAMED_TYPE to have right associativity *) */ -decl_spec_list_opt: - /* empty */ { [] } %prec NAMED_TYPE -| decl_spec_list { fst $1 } -; -/* (* We add this separate rule to handle the special case when an appearance - * of NAMED_TYPE should not be considered as part of the specifiers but as - * part of the declarator. IDENT has higher precedence than NAMED_TYPE *) - */ -decl_spec_list_opt_no_named: - /* empty */ { [] } %prec IDENT -| decl_spec_list { fst $1 } -; -type_spec: /* ISO 6.7.2 */ - VOID { Tvoid, $1} -| CHAR { Tchar, $1 } -| SHORT { Tshort, $1 } -| INT { Tint, $1 } -| LONG { Tlong, $1 } -| INT64 { Tint64, $1 } -| FLOAT { Tfloat, $1 } -| DOUBLE { Tdouble, $1 } -| SIGNED { Tsigned, $1 } -| UNSIGNED { Tunsigned, $1 } -| STRUCT id_or_typename - { Tstruct ($2, None, []), $1 } -| STRUCT just_attributes id_or_typename - { Tstruct ($3, None, $2), $1 } -| STRUCT id_or_typename LBRACE struct_decl_list RBRACE - { Tstruct ($2, Some $4, []), $1 } -| STRUCT LBRACE struct_decl_list RBRACE - { Tstruct ("", Some $3, []), $1 } -| STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE - { Tstruct ($3, Some $5, $2), $1 } -| STRUCT just_attributes LBRACE struct_decl_list RBRACE - { Tstruct ("", Some $4, $2), $1 } -| UNION id_or_typename - { Tunion ($2, None, []), $1 } -| UNION id_or_typename LBRACE struct_decl_list RBRACE - { Tunion ($2, Some $4, []), $1 } -| UNION LBRACE struct_decl_list RBRACE - { Tunion ("", Some $3, []), $1 } -| UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE - { Tunion ($3, Some $5, $2), $1 } -| UNION just_attributes LBRACE struct_decl_list RBRACE - { Tunion ("", Some $4, $2), $1 } -| ENUM id_or_typename - { Tenum ($2, None, []), $1 } -| ENUM id_or_typename LBRACE enum_list maybecomma RBRACE - { Tenum ($2, Some $4, []), $1 } -| ENUM LBRACE enum_list maybecomma RBRACE - { Tenum ("", Some $3, []), $1 } -| ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE - { Tenum ($3, Some $5, $2), $1 } -| ENUM just_attributes LBRACE enum_list maybecomma RBRACE - { Tenum ("", Some $4, $2), $1 } -| NAMED_TYPE { Tnamed (fst $1), snd $1 } -| TYPEOF LPAREN expression RPAREN { TtypeofE (fst $3), $1 } -| TYPEOF LPAREN type_name RPAREN { let s, d = $3 in - TtypeofT (s, d), $1 } -; -struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We - * also allow missing field names. *) - */ - /* empty */ { [] } -| decl_spec_list SEMICOLON struct_decl_list - { (fst $1, - [(missingFieldDecl, None)]) :: $3 } -/*(* GCC allows extra semicolons *)*/ -| SEMICOLON struct_decl_list - { $2 } -| decl_spec_list field_decl_list SEMICOLON struct_decl_list - { (fst $1, $2) - :: $4 } -/*(* MSVC allows pragmas in strange places *)*/ -| pragma struct_decl_list { $2 } - -| error SEMICOLON struct_decl_list - { $3 } -; -field_decl_list: /* (* ISO 6.7.2 *) */ - field_decl { [$1] } -| field_decl COMMA field_decl_list { $1 :: $3 } -; -field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */ -| declarator { ($1, None) } -| declarator COLON expression { ($1, Some (fst $3)) } -| COLON expression { (missingFieldDecl, Some (fst $2)) } -; - -enum_list: /* (* ISO 6.7.2.2 *) */ - enumerator {[$1]} -| enum_list COMMA enumerator {$1 @ [$3]} -| enum_list COMMA error { $1 } -; -enumerator: - IDENT {(fst $1, NOTHING, snd $1)} -| IDENT EQ expression {(fst $1, fst $3, snd $1)} -; - - -declarator: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */ - pointer_opt direct_decl attributes_with_asm - { let (n, decl) = $2 in - (n, applyPointer (fst $1) decl, $3, (*(*handleLoc*)*)(snd $1)) } -; - - -direct_decl: /* (* ISO 6.7.5 *) */ - /* (* We want to be able to redefine named - * types as variable names *) */ -| id_or_typename { ($1, JUSTBASE) } - -| LPAREN attributes declarator RPAREN - { let (n,decl,al,loc) = $3 in - (n, PARENTYPE($2,decl,al)) } - -| direct_decl LBRACKET attributes comma_expression_opt RBRACKET - { let (n, decl) = $1 in - (n, ARRAY(decl, $3, $4)) } -| direct_decl LBRACKET attributes error RBRACKET - { let (n, decl) = $1 in - (n, ARRAY(decl, $3, NOTHING)) } -| direct_decl parameter_list_startscope rest_par_list RPAREN - { let (n, decl) = $1 in - let (params, isva) = $3 in - !Lexerhack.pop_context (); - (n, PROTO(decl, params, isva)) - } -; -parameter_list_startscope: - LPAREN { !Lexerhack.push_context () } -; -rest_par_list: -| /* empty */ { ([], false) } -| parameter_decl rest_par_list1 { let (params, isva) = $2 in - ($1 :: params, isva) - } -; -rest_par_list1: - /* empty */ { ([], false) } -| COMMA ELLIPSIS { ([], true) } -| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in - ($2 :: params, isva) - } -; - - -parameter_decl: /* (* ISO 6.7.5 *) */ - decl_spec_list declarator { (fst $1, $2) } -| decl_spec_list abstract_decl { let d, a = $2 in - (fst $1, ("", d, a, cabslu)) } -| decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) } -| LPAREN parameter_decl RPAREN { $2 } -; - -/* (* Old style prototypes. Like a declarator *) */ -old_proto_decl: - pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in - (n, applyPointer (fst $1) decl, - a, snd $1) - } - -; - -direct_old_proto_decl: - direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list - { let par_decl, isva = doOldParDecl $3 $5 in - let n, decl = $1 in - (n, PROTO(decl, par_decl, isva), []) - } -| direct_decl LPAREN RPAREN - { let n, decl = $1 in - (n, PROTO(decl, [], false), []) - } - -/* (* appears sometimesm but generates a shift-reduce conflict. *) -| LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list - { let par_decl, isva - = doOldParDecl $5 $10 in - let n, decl = $3 in - (n, PROTO(decl, par_decl, isva), []) - } -*/ -; - -old_parameter_list_ne: -| IDENT { [fst $1] } -| IDENT COMMA old_parameter_list_ne { let rest = $3 in - (fst $1 :: rest) } -; - -old_pardef_list: - /* empty */ { ([], false) } -| decl_spec_list old_pardef SEMICOLON ELLIPSIS - { ([(fst $1, $2)], true) } -| decl_spec_list old_pardef SEMICOLON old_pardef_list - { let rest, isva = $4 in - ((fst $1, $2) :: rest, isva) - } -; - -old_pardef: - declarator { [$1] } -| declarator COMMA old_pardef { $1 :: $3 } -| error { [] } -; - - -pointer: /* (* ISO 6.7.5 *) */ - STAR attributes pointer_opt { $2 :: fst $3, $1 } -; -pointer_opt: - /**/ { let l = currentLoc () in - ([], l) } -| pointer { $1 } -; - -type_name: /* (* ISO 6.7.6 *) */ - decl_spec_list abstract_decl { let d, a = $2 in - if a <> [] then begin - parse_error "attributes in type name"; - raise Parsing.Parse_error - end; - (fst $1, d) - } -| decl_spec_list { (fst $1, JUSTBASE) } -; -abstract_decl: /* (* ISO 6.7.6. *) */ - pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 } -| pointer { applyPointer (fst $1) JUSTBASE, [] } -; - -abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for - * functions. Plus Microsoft attributes. See the - * discussion for declarator. *) */ -| LPAREN attributes abstract_decl RPAREN - { let d, a = $3 in - PARENTYPE ($2, d, a) - } - -| LPAREN error RPAREN - { JUSTBASE } - -| abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET - { ARRAY($1, [], $3) } -/*(* The next should be abs_direct_decl_opt but we get conflicts *)*/ -| abs_direct_decl parameter_list_startscope rest_par_list RPAREN - { let (params, isva) = $3 in - !Lexerhack.pop_context (); - PROTO ($1, params, isva) - } -; -abs_direct_decl_opt: - abs_direct_decl { $1 } -| /* empty */ { JUSTBASE } -; -function_def: /* (* ISO 6.9.1 *) */ - function_def_start block - { let (loc, specs, decl) = $1 in - currentFunctionName := "<__FUNCTION__ used outside any functions>"; - !Lexerhack.pop_context (); (* The context pushed by - * announceFunctionName *) - doFunctionDef ((*handleLoc*) loc) (trd3 $2) specs decl (fst3 $2) - } - - -function_def_start: /* (* ISO 6.9.1 *) */ - decl_spec_list declarator - { announceFunctionName $2; - (snd $1, fst $1, $2) - } - -/* (* Old-style function prototype *) */ -| decl_spec_list old_proto_decl - { announceFunctionName $2; - (snd $1, fst $1, $2) - } -/* (* New-style function that does not have a return type *) */ -| IDENT parameter_list_startscope rest_par_list RPAREN - { let (params, isva) = $3 in - let fdec = - (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in - announceFunctionName fdec; - (* Default is int type *) - let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) - } - -/* (* No return type and old-style parameter list *) */ -| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list - { (* Convert pardecl to new style *) - let pardecl, isva = doOldParDecl $3 $5 in - (* Make the function declarator *) - let fdec = (fst $1, - PROTO(JUSTBASE, pardecl,isva), - [], snd $1) in - announceFunctionName fdec; - (* Default is int type *) - let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) - } -/* (* No return type and no parameters *) */ -| IDENT LPAREN RPAREN - { (* Make the function declarator *) - let fdec = (fst $1, - PROTO(JUSTBASE, [], false), - [], snd $1) in - announceFunctionName fdec; - (* Default is int type *) - let defSpec = [SpecType Tint] in - (snd $1, defSpec, fdec) - } -; - -/* const/volatile as type specifier elements */ -cvspec: - CONST { SpecCV(CV_CONST), $1 } -| VOLATILE { SpecCV(CV_VOLATILE), $1 } -| RESTRICT { SpecCV(CV_RESTRICT), $1 } -; - -/*** GCC attributes ***/ -attributes: - /* empty */ { []} -| attribute attributes { fst $1 :: $2 } -; - -/* (* In some contexts we can have an inline assembly to specify the name to - * be used for a global. We treat this as a name attribute *) */ -attributes_with_asm: - /* empty */ { [] } -| attribute attributes_with_asm { fst $1 :: $2 } -| ASM LPAREN string_constant RPAREN attributes - { ("__asm__", - [CONSTANT(CONST_STRING (fst $3))]) :: $5 } -; - -/* things like __attribute__, but no const/volatile */ -attribute_nocv: - ATTRIBUTE LPAREN paren_attr_list_ne RPAREN - { ("__attribute__", $3), $1 } -/*(* -| ATTRIBUTE_USED { ("__attribute__", - [ VARIABLE "used" ]), $1 } -*)*/ -| DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 } -| MSATTR { (fst $1, []), snd $1 } - /* ISO 6.7.3 */ -| THREAD { ("__thread",[]), $1 } -; - -/* __attribute__ plus const/volatile */ -attribute: - attribute_nocv { $1 } -| CONST { ("const", []), $1 } -| RESTRICT { ("restrict",[]), $1 } -| VOLATILE { ("volatile",[]), $1 } -; - -/* (* sm: I need something that just includes __attribute__ and nothing more, - * to support them appearing between the 'struct' keyword and the type name. - * Actually, a declspec can appear there as well (on MSVC) *) */ -just_attribute: - ATTRIBUTE LPAREN paren_attr_list_ne RPAREN - { ("__attribute__", $3) } -| DECLSPEC paren_attr_list_ne { ("__declspec", $2) } -; - -/* this can't be empty, b/c I folded that possibility into the calling - * productions to avoid some S/R conflicts */ -just_attributes: - just_attribute { [$1] } -| just_attribute just_attributes { $1 :: $2 } -; - -/** (* PRAGMAS and ATTRIBUTES *) ***/ -pragma: -| PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) } -| PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $1) } -| PRAGMA_LINE { PRAGMA (VARIABLE (fst $1), - snd $1) } -; - -/* (* We want to allow certain strange things that occur in pragmas, so we - * cannot use directly the language of expressions *) */ -primary_attr: - IDENT { VARIABLE (fst $1) } - /*(* The NAMED_TYPE here creates conflicts with IDENT *)*/ -| NAMED_TYPE { VARIABLE (fst $1) } -| LPAREN attr RPAREN { $2 } -| IDENT IDENT { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) } -| CST_INT { CONSTANT(CONST_INT (fst $1)) } -| string_constant { CONSTANT(CONST_STRING (fst $1)) } - /*(* Const when it appears in - * attribute lists, is translated - * to aconst *)*/ -| CONST { VARIABLE "aconst" } -| IDENT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } - -| CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } -| DEFAULT COLON CST_INT { VARIABLE ("default:" ^ fst $3) } - - /*(** GCC allows this as an - * attribute for functions, - * synonim for noreturn **)*/ -| VOLATILE { VARIABLE ("__noreturn__") } -; - -postfix_attr: - primary_attr { $1 } - /* (* use a VARIABLE "" so that the - * parentheses are printed *) */ -| IDENT LPAREN RPAREN { CALL(VARIABLE (fst $1), [VARIABLE ""]) } -| IDENT paren_attr_list_ne { CALL(VARIABLE (fst $1), $2) } - -| postfix_attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)} -| postfix_attr DOT id_or_typename {MEMBEROF ($1, $3)} -; - -/*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers, - * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require - * that their arguments be expressions, not attributes *)*/ -unary_attr: - postfix_attr { $1 } -| SIZEOF unary_expression {EXPR_SIZEOF (fst $2) } -| SIZEOF LPAREN type_name RPAREN - {let b, d = $3 in TYPE_SIZEOF (b, d)} - -| ALIGNOF unary_expression {EXPR_ALIGNOF (fst $2) } -| ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_ALIGNOF (b, d)} -| PLUS cast_attr {UNARY (PLUS, $2)} -| MINUS cast_attr {UNARY (MINUS, $2)} -| STAR cast_attr {UNARY (MEMOF, $2)} -| AND cast_attr - {UNARY (ADDROF, $2)} -| EXCLAM cast_attr {UNARY (NOT, $2)} -| TILDE cast_attr {UNARY (BNOT, $2)} -; - -cast_attr: - unary_attr { $1 } -; - -multiplicative_attr: - cast_attr { $1 } -| multiplicative_attr STAR cast_attr {BINARY(MUL ,$1 , $3)} -| multiplicative_attr SLASH cast_attr {BINARY(DIV ,$1 , $3)} -| multiplicative_attr PERCENT cast_attr {BINARY(MOD ,$1 , $3)} -; - - -additive_attr: - multiplicative_attr { $1 } -| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)} -| additive_attr MINUS multiplicative_attr {BINARY(SUB ,$1 , $3)} -; - -shift_attr: - additive_attr { $1 } -| shift_attr INF_INF additive_attr {BINARY(SHL ,$1 , $3)} -| shift_attr SUP_SUP additive_attr {BINARY(SHR ,$1 , $3)} -; - -relational_attr: - shift_attr { $1 } -| relational_attr INF shift_attr {BINARY(LT ,$1 , $3)} -| relational_attr SUP shift_attr {BINARY(GT ,$1 , $3)} -| relational_attr INF_EQ shift_attr {BINARY(LE ,$1 , $3)} -| relational_attr SUP_EQ shift_attr {BINARY(GE ,$1 , $3)} -; - -equality_attr: - relational_attr { $1 } -| equality_attr EQ_EQ relational_attr {BINARY(EQ ,$1 , $3)} -| equality_attr EXCLAM_EQ relational_attr {BINARY(NE ,$1 , $3)} -; - - -bitwise_and_attr: - equality_attr { $1 } -| bitwise_and_attr AND equality_attr {BINARY(BAND ,$1 , $3)} -; - -bitwise_xor_attr: - bitwise_and_attr { $1 } -| bitwise_xor_attr CIRC bitwise_and_attr {BINARY(XOR ,$1 , $3)} -; - -bitwise_or_attr: - bitwise_xor_attr { $1 } -| bitwise_or_attr PIPE bitwise_xor_attr {BINARY(BOR ,$1 , $3)} -; - -logical_and_attr: - bitwise_or_attr { $1 } -| logical_and_attr AND_AND bitwise_or_attr {BINARY(AND ,$1 , $3)} -; - -logical_or_attr: - logical_and_attr { $1 } -| logical_or_attr PIPE_PIPE logical_and_attr {BINARY(OR ,$1 , $3)} -; - - -attr: logical_or_attr { $1 } -; - -attr_list_ne: -| attr { [$1] } -| attr COMMA attr_list_ne { $1 :: $3 } -| error COMMA attr_list_ne { $3 } -; -paren_attr_list_ne: - LPAREN attr_list_ne RPAREN { $2 } -| LPAREN error RPAREN { [] } -; -/*** GCC ASM instructions ***/ -asmattr: - /* empty */ { [] } -| VOLATILE asmattr { ("volatile", []) :: $2 } -| CONST asmattr { ("const", []) :: $2 } -; -asmtemplate: - one_string_constant { [$1] } -| one_string_constant asmtemplate { $1 :: $2 } -; -asmoutputs: - /* empty */ { None } -| COLON asmoperands asminputs - { let (ins, clobs) = $3 in - Some {aoutputs = $2; ainputs = ins; aclobbers = clobs} } -; -asmoperands: - /* empty */ { [] } -| asmoperandsne { List.rev $1 } -; -asmoperandsne: - asmoperand { [$1] } -| asmoperandsne COMMA asmoperand { $3 :: $1 } -; -asmoperand: - string_constant LPAREN expression RPAREN { (fst $1, fst $3) } -| string_constant LPAREN error RPAREN { (fst $1, NOTHING ) } -; -asminputs: - /* empty */ { ([], []) } -| COLON asmoperands asmclobber - { ($2, $3) } -; -asmclobber: - /* empty */ { [] } -| COLON asmcloberlst_ne { $2 } -; -asmcloberlst_ne: - one_string_constant { [$1] } -| one_string_constant COMMA asmcloberlst_ne { $1 :: $3 } -; - -%% - - - diff --git a/cil/src/frontc/cprint.ml b/cil/src/frontc/cprint.ml deleted file mode 100644 index 570945c..0000000 --- a/cil/src/frontc/cprint.ml +++ /dev/null @@ -1,1014 +0,0 @@ -(* - * - * Copyright (c) 2001-2003, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) -(* cprint -- pretty printer of C program from abstract syntax -** -** Project: FrontC -** File: cprint.ml -** Version: 2.1e -** Date: 9.1.99 -** Author: Hugues Cassé -** -** 1.0 2.22.99 Hugues Cassé First version. -** 2.0 3.18.99 Hugues Cassé Compatible with Frontc 2.1, use of CAML -** pretty printer. -** 2.1 3.22.99 Hugues Cassé More efficient custom pretty printer used. -** 2.1a 4.12.99 Hugues Cassé Correctly handle: -** char *m, *m, *p; m + (n - p) -** 2.1b 4.15.99 Hugues Cassé x + (y + z) stays x + (y + z) for -** keeping computation order. -** 2.1c 7.23.99 Hugues Cassé Improvement of case and default display. -** 2.1d 8.25.99 Hugues Cassé Rebuild escape sequences in string and -** characters. -** 2.1e 9.1.99 Hugues Cassé Fix, recognize and correctly display '\0'. -*) - -(* George Necula: I changed this pretty dramatically since CABS changed *) -open Cabs -open Escape -let version = "Cprint 2.1e 9.1.99 Hugues Cassé" - -type loc = { line : int; file : string } - -let lu = {line = -1; file = "loc unknown";} -let cabslu = {lineno = -10; - filename = "cabs loc unknown"; - byteno = -10;} - -let curLoc = ref cabslu - -let msvcMode = ref false - -let printLn = ref true -let printLnComment = ref false - -let printCounters = ref false -let printComments = ref false - -(* -** FrontC Pretty printer -*) -let out = ref stdout -let width = ref 80 -let tab = ref 2 -let max_indent = ref 60 - -let line = ref "" -let line_len = ref 0 -let current = ref "" -let current_len = ref 0 -let spaces = ref 0 -let follow = ref 0 -let roll = ref 0 - -let print_tab size = - for i = 1 to size / 8 do - output_char !out '\t' - done; - for i = 1 to size mod 8 do - output_char !out ' ' - done - -let flush _ = - if !line <> "" then begin - print_tab (!spaces + !follow); - output_string !out !line; - line := ""; - line_len := 0 - end - -let commit _ = - if !current <> "" then begin - if !line = "" then begin - line := !current; - line_len := !current_len - end else begin - line := (!line ^ " " ^ !current); - line_len := !line_len + 1 + !current_len - end; - current := ""; - current_len := 0 - end - - -let addline () = - curLoc := {lineno = !curLoc.lineno+1; - filename = !curLoc.filename; - byteno = -1;} (*sfg: can we do better than this?*) - - -let new_line _ = - commit (); - if !line <> "" then begin - flush (); - addline(); - output_char !out '\n' - end; - follow := 0 - -let force_new_line _ = - commit (); - flush (); - addline(); - output_char !out '\n'; - follow := 0 - -let indent _ = - new_line (); - spaces := !spaces + !tab; - if !spaces >= !max_indent then begin - spaces := !tab; - roll := !roll + 1 - end - -let indentline _ = - new_line (); - if !spaces >= !max_indent then begin - spaces := !tab; - roll := !roll + 1 - end - -let unindent _ = - new_line (); - spaces := !spaces - !tab; - if (!spaces <= 0) && (!roll > 0) then begin - spaces := ((!max_indent - 1) / !tab) * !tab; - roll := !roll - 1 - end - -let space _ = commit () - -let print str = - current := !current ^ str; - current_len := !current_len + (String.length str); - if (!spaces + !follow + !line_len + 1 + !current_len) > !width - then begin - if !line_len = 0 then commit (); - flush (); - addline(); - output_char !out '\n'; - if !follow = 0 then follow := !tab - end - -(* sm: for some reason I couldn't just call print from frontc.... ? *) -let print_unescaped_string str = print str - -let setLoc (l : cabsloc) = - if !printLn then - if (l.lineno <> !curLoc.lineno) || l.filename <> !curLoc.filename then - begin - let oldspaces = !spaces in - (* sm: below, we had '//#' instead of '#', which means printLnComment was disregarded *) - if !printLnComment then print "//" else print "#"; - if !msvcMode then print "line"; - print " "; - print (string_of_int l.lineno); - if (l.filename <> !curLoc.filename) then begin - print (" \"" ^ l.filename ^ "\"") - end; - spaces := oldspaces; - new_line(); - curLoc := l - end - - - -(* -** Useful primitives -*) -let print_list print_sep print_elt lst = - let _ = List.fold_left - (fun com elt -> - if com then print_sep (); - print_elt elt; - true) - false - lst in - () - -let print_commas nl fct lst = - print_list (fun () -> print ","; if nl then new_line() else space()) fct lst - -let print_string (s:string) = - print ("\"" ^ escape_string s ^ "\"") - -let print_wstring (s: int64 list ) = - print ("L\"" ^ escape_wstring s ^ "\"") - -(* -** Base Type Printing -*) - -let rec print_specifiers (specs: spec_elem list) = - comprint "specifier("; - let print_spec_elem = function - SpecTypedef -> print "typedef " - | SpecInline -> print "__inline " - | SpecStorage sto -> - print (match sto with - NO_STORAGE -> (comstring "/*no storage*/") - | AUTO -> "auto " - | STATIC -> "static " - | EXTERN -> "extern " - | REGISTER -> "register ") - | SpecCV cv -> - print (match cv with - | CV_CONST -> "const " - | CV_VOLATILE -> "volatile " - | CV_RESTRICT -> "restrict ") - | SpecAttr al -> print_attribute al; space () - | SpecType bt -> print_type_spec bt - | SpecPattern name -> print ("@specifier(" ^ name ^ ") ") - in - List.iter print_spec_elem specs - ;comprint ")" - - -and print_type_spec = function - Tvoid -> print "void " - | Tchar -> print "char " - | Tshort -> print "short " - | Tint -> print "int " - | Tlong -> print "long " - | Tint64 -> print "__int64 " - | Tfloat -> print "float " - | Tdouble -> print "double " - | Tsigned -> print "signed " - | Tunsigned -> print "unsigned " - | Tnamed s -> comprint "tnamed"; print s; space (); - | Tstruct (n, None, _) -> print ("struct " ^ n ^ " ") - | Tstruct (n, Some flds, extraAttrs) -> - (print_struct_name_attr "struct" n extraAttrs); - (print_fields flds) - | Tunion (n, None, _) -> print ("union " ^ n ^ " ") - | Tunion (n, Some flds, extraAttrs) -> - (print_struct_name_attr "union" n extraAttrs); - (print_fields flds) - | Tenum (n, None, _) -> print ("enum " ^ n ^ " ") - | Tenum (n, Some enum_items, extraAttrs) -> - (print_struct_name_attr "enum" n extraAttrs); - (print_enum_items enum_items) - | TtypeofE e -> print "__typeof__("; print_expression e; print ") " - | TtypeofT (s,d) -> print "__typeof__("; print_onlytype (s, d); print ") " - - -(* print "struct foo", but with specified keyword and a list of - * attributes to put between keyword and name *) -and print_struct_name_attr (keyword: string) (name: string) (extraAttrs: attribute list) = -begin - if extraAttrs = [] then - print (keyword ^ " " ^ name) - else begin - (print (keyword ^ " ")); - (print_attributes extraAttrs); (* prints a final space *) - (print name); - end -end - - -(* This is the main printer for declarations. It is easy bacause the - * declarations are laid out as they need to be printed. *) -and print_decl (n: string) = function - JUSTBASE -> if n <> "___missing_field_name" then - print n - else - comprint "missing field name" - | PARENTYPE (al1, d, al2) -> - print "("; - print_attributes al1; space (); - print_decl n d; space (); - print_attributes al2; print ")" - | PTR (al, d) -> - print "* "; - print_attributes al; space (); - print_decl n d - | ARRAY (d, al, e) -> - print_decl n d; - print "["; - print_attributes al; - if e <> NOTHING then print_expression e; - print "]" - | PROTO(d, args, isva) -> - comprint "proto("; - print_decl n d; - print "("; - print_params args isva; - print ")"; - comprint ")" - - -and print_fields (flds : field_group list) = - if flds = [] then print " { } " - else begin - print " {"; - indent (); - List.iter - (fun fld -> print_field_group fld; print ";"; new_line ()) - flds; - unindent (); - print "} " - end - -and print_enum_items items = - if items = [] then print " { } " - else begin - print " {"; - indent (); - print_commas - true - (fun (id, exp, loc) -> print id; - if exp = NOTHING then () - else begin - space (); - print "= "; - print_expression exp - end) - items; - unindent (); - print "} "; - end - - -and print_onlytype (specs, dt) = - print_specifiers specs; - print_decl "" dt - -and print_name ((n, decl, attrs, _) : name) = - print_decl n decl; - space (); - print_attributes attrs - -and print_init_name ((n, i) : init_name) = - print_name n; - if i <> NO_INIT then begin - space (); - print "= "; - print_init_expression i - end - -and print_name_group (specs, names) = - print_specifiers specs; - print_commas false print_name names - -and print_field_group (specs, fields) = - print_specifiers specs; - print_commas false print_field fields - - -and print_field (name, widtho) = - print_name name; - (match widtho with - None -> () - | Some w -> print " : "; print_expression w) - -and print_init_name_group (specs, names) = - print_specifiers specs; - print_commas false print_init_name names - -and print_single_name (specs, name) = - print_specifiers specs; - print_name name - -and print_params (pars : single_name list) (ell : bool) = - print_commas false print_single_name pars; - if ell then print (if pars = [] then "..." else ", ...") else () - -and print_old_params pars ell = - print_commas false (fun id -> print id) pars; - if ell then print (if pars = [] then "..." else ", ...") else () - - -(* -** Expression printing -** Priorities -** 16 variables -** 15 . -> [] call() -** 14 ++, -- (post) -** 13 ++ -- (pre) ~ ! - + & *(cast) -** 12 * / % -** 11 + - -** 10 << >> -** 9 < <= > >= -** 8 == != -** 7 & -** 6 ^ -** 5 | -** 4 && -** 3 || -** 2 ? : -** 1 = ?= -** 0 , -*) -and get_operator exp = - match exp with - NOTHING -> ("", 16) - | UNARY (op, _) -> - (match op with - MINUS -> ("-", 13) - | PLUS -> ("+", 13) - | NOT -> ("!", 13) - | BNOT -> ("~", 13) - | MEMOF -> ("*", 13) - | ADDROF -> ("&", 13) - | PREINCR -> ("++", 13) - | PREDECR -> ("--", 13) - | POSINCR -> ("++", 14) - | POSDECR -> ("--", 14)) - | LABELADDR s -> ("", 16) (* Like a constant *) - | BINARY (op, _, _) -> - (match op with - MUL -> ("*", 12) - | DIV -> ("/", 12) - | MOD -> ("%", 12) - | ADD -> ("+", 11) - | SUB -> ("-", 11) - | SHL -> ("<<", 10) - | SHR -> (">>", 10) - | LT -> ("<", 9) - | LE -> ("<=", 9) - | GT -> (">", 9) - | GE -> (">=", 9) - | EQ -> ("==", 8) - | NE -> ("!=", 8) - | BAND -> ("&", 7) - | XOR -> ("^", 6) - | BOR -> ("|", 5) - | AND -> ("&&", 4) - | OR -> ("||", 3) - | ASSIGN -> ("=", 1) - | ADD_ASSIGN -> ("+=", 1) - | SUB_ASSIGN -> ("-=", 1) - | MUL_ASSIGN -> ("*=", 1) - | DIV_ASSIGN -> ("/=", 1) - | MOD_ASSIGN -> ("%=", 1) - | BAND_ASSIGN -> ("&=", 1) - | BOR_ASSIGN -> ("|=", 1) - | XOR_ASSIGN -> ("^=", 1) - | SHL_ASSIGN -> ("<<=", 1) - | SHR_ASSIGN -> (">>=", 1)) - | QUESTION _ -> ("", 2) - | CAST _ -> ("", 13) - | CALL _ -> ("", 15) - | COMMA _ -> ("", 0) - | CONSTANT _ -> ("", 16) - | VARIABLE name -> ("", 16) - | EXPR_SIZEOF exp -> ("", 16) - | TYPE_SIZEOF _ -> ("", 16) - | EXPR_ALIGNOF exp -> ("", 16) - | TYPE_ALIGNOF _ -> ("", 16) - | INDEX (exp, idx) -> ("", 15) - | MEMBEROF (exp, fld) -> ("", 15) - | MEMBEROFPTR (exp, fld) -> ("", 15) - | GNU_BODY _ -> ("", 17) - | EXPR_PATTERN _ -> ("", 16) (* sm: not sure about this *) - -and print_comma_exps exps = - print_commas false print_expression exps - -and print_init_expression (iexp: init_expression) : unit = - match iexp with - NO_INIT -> () - | SINGLE_INIT e -> print_expression e - | COMPOUND_INIT initexps -> - let doinitexp = function - NEXT_INIT, e -> print_init_expression e - | i, e -> - let rec doinit = function - NEXT_INIT -> () - | INFIELD_INIT (fn, i) -> print ("." ^ fn); doinit i - | ATINDEX_INIT (e, i) -> - print "["; - print_expression e; - print "]"; - doinit i - | ATINDEXRANGE_INIT (s, e) -> - print "["; - print_expression s; - print " ... "; - print_expression e; - print "]" - in - doinit i; print " = "; - print_init_expression e - in - print "{"; - print_commas false doinitexp initexps; - print "}" - -and print_expression (exp: expression) = print_expression_level 1 exp - -and print_expression_level (lvl: int) (exp : expression) = - let (txt, lvl') = get_operator exp in - let _ = if lvl > lvl' then print "(" else () in - let _ = match exp with - NOTHING -> () - | UNARY (op, exp') -> - (match op with - POSINCR | POSDECR -> - print_expression_level lvl' exp'; - print txt - | _ -> - print txt; space (); (* Print the space to avoid --5 *) - print_expression_level lvl' exp') - | LABELADDR l -> print ("&& " ^ l) - | BINARY (op, exp1, exp2) -> - (*if (op = SUB) && (lvl <= lvl') then print "(";*) - print_expression_level lvl' exp1; - space (); - print txt; - space (); - (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*) - print_expression_level (lvl' + 1) exp2 - (*if (op = SUB) && (lvl <= lvl') then print ")"*) - | QUESTION (exp1, exp2, exp3) -> - print_expression_level 2 exp1; - space (); - print "? "; - print_expression_level 2 exp2; - space (); - print ": "; - print_expression_level 2 exp3; - | CAST (typ, iexp) -> - print "("; - print_onlytype typ; - print ")"; - (* Always print parentheses. In a small number of cases when we print - * constants we don't need them *) - (match iexp with - SINGLE_INIT e -> print_expression_level 15 e - | COMPOUND_INIT _ -> (* print "("; *) - print_init_expression iexp - (* ; print ")" *) - | NO_INIT -> print "") - - | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) -> - comprint "variable"; - print "__builtin_va_arg"; - print "("; - print_expression_level 1 arg; - print ","; - print_onlytype (bt, dt); - print ")" - | CALL (exp, args) -> - print_expression_level 16 exp; - print "("; - print_comma_exps args; - print ")" - | COMMA exps -> - print_comma_exps exps - | CONSTANT cst -> - (match cst with - CONST_INT i -> print i - | CONST_FLOAT r -> print r - | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'") - | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'") - | CONST_STRING s -> print_string s - | CONST_WSTRING ws -> print_wstring ws) - | VARIABLE name -> - comprint "variable"; - print name - | EXPR_SIZEOF exp -> - print "sizeof("; - print_expression_level 0 exp; - print ")" - | TYPE_SIZEOF (bt,dt) -> - print "sizeof("; - print_onlytype (bt, dt); - print ")" - | EXPR_ALIGNOF exp -> - print "__alignof__("; - print_expression_level 0 exp; - print ")" - | TYPE_ALIGNOF (bt,dt) -> - print "__alignof__("; - print_onlytype (bt, dt); - print ")" - | INDEX (exp, idx) -> - print_expression_level 16 exp; - print "["; - print_expression_level 0 idx; - print "]" - | MEMBEROF (exp, fld) -> - print_expression_level 16 exp; - print ("." ^ fld) - | MEMBEROFPTR (exp, fld) -> - print_expression_level 16 exp; - print ("->" ^ fld) - | GNU_BODY (blk) -> - print "("; - print_block blk; - print ")" - | EXPR_PATTERN (name) -> - print ("@expr(" ^ name ^ ") ") - in - if lvl > lvl' then print ")" else () - - -(* -** Statement printing -*) -and print_statement stat = - match stat with - NOP (loc) -> - setLoc(loc); - print ";"; - new_line () - | COMPUTATION (exp, loc) -> - setLoc(loc); - print_expression exp; - print ";"; - new_line () - | BLOCK (blk, loc) -> print_block blk - - | SEQUENCE (s1, s2, loc) -> - setLoc(loc); - print_statement s1; - print_statement s2; - | IF (exp, s1, s2, loc) -> - setLoc(loc); - print "if("; - print_expression_level 0 exp; - print ")"; - print_substatement s1; - (match s2 with - | NOP(_) -> () - | _ -> begin - print "else"; - print_substatement s2; - end) - | WHILE (exp, stat, loc) -> - setLoc(loc); - print "while("; - print_expression_level 0 exp; - print ")"; - print_substatement stat - | DOWHILE (exp, stat, loc) -> - setLoc(loc); - print "do"; - print_substatement stat; - print "while("; - print_expression_level 0 exp; - print ");"; - new_line (); - | FOR (fc1, exp2, exp3, stat, loc) -> - setLoc(loc); - print "for("; - (match fc1 with - FC_EXP exp1 -> print_expression_level 0 exp1; print ";" - | FC_DECL dec1 -> print_def dec1); - space (); - print_expression_level 0 exp2; - print ";"; - space (); - print_expression_level 0 exp3; - print ")"; - print_substatement stat - | BREAK (loc)-> - setLoc(loc); - print "break;"; new_line () - | CONTINUE (loc) -> - setLoc(loc); - print "continue;"; new_line () - | RETURN (exp, loc) -> - setLoc(loc); - print "return"; - if exp = NOTHING - then () - else begin - print " "; - print_expression_level 1 exp - end; - print ";"; - new_line () - | SWITCH (exp, stat, loc) -> - setLoc(loc); - print "switch("; - print_expression_level 0 exp; - print ")"; - print_substatement stat - | CASE (exp, stat, loc) -> - setLoc(loc); - unindent (); - print "case "; - print_expression_level 1 exp; - print ":"; - indent (); - print_substatement stat - | CASERANGE (expl, exph, stat, loc) -> - setLoc(loc); - unindent (); - print "case "; - print_expression expl; - print " ... "; - print_expression exph; - print ":"; - indent (); - print_substatement stat - | DEFAULT (stat, loc) -> - setLoc(loc); - unindent (); - print "default :"; - indent (); - print_substatement stat - | LABEL (name, stat, loc) -> - setLoc(loc); - print (name ^ ":"); - space (); - print_substatement stat - | GOTO (name, loc) -> - setLoc(loc); - print ("goto " ^ name ^ ";"); - new_line () - | COMPGOTO (exp, loc) -> - setLoc(loc); - print ("goto *"); print_expression exp; print ";"; new_line () - | DEFINITION d -> - print_def d - | ASM (attrs, tlist, details, loc) -> - setLoc(loc); - let print_asm_operand (cnstr, e) = - print_string cnstr; space (); print_expression_level 100 e - in - if !msvcMode then begin - print "__asm {"; - print_list (fun () -> new_line()) print tlist; (* templates *) - print "};" - end else begin - print "__asm__ "; - print_attributes attrs; - print "("; - print_list (fun () -> new_line()) print_string tlist; (* templates *) - begin - match details with - | None -> () - | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> - print ":"; space (); - print_commas false print_asm_operand outs; - if ins <> [] || clobs <> [] then begin - print ":"; space (); - print_commas false print_asm_operand ins; - if clobs <> [] then begin - print ":"; space (); - print_commas false print_string clobs - end; - end - end; - print ");" - end; - new_line () - | TRY_FINALLY (b, h, loc) -> - setLoc loc; - print "__try "; - print_block b; - print "__finally "; - print_block h - - | TRY_EXCEPT (b, e, h, loc) -> - setLoc loc; - print "__try "; - print_block b; - print "__except("; print_expression e; print ")"; - print_block h - -and print_block blk = - new_line(); - print "{"; - indent (); - if blk.blabels <> [] then begin - print "__label__ "; - print_commas false print blk.blabels; - print ";"; - new_line (); - end; - if blk.battrs <> [] then begin - List.iter print_attribute blk.battrs; - new_line (); - end; - List.iter print_statement blk.bstmts; - unindent (); - print "}"; - new_line () - -and print_substatement stat = - match stat with - IF _ - | SEQUENCE _ - | DOWHILE _ -> - new_line (); - print "{"; - indent (); - print_statement stat; - unindent (); - print "}"; - new_line (); - | BLOCK _ -> - print_statement stat - | _ -> - indent (); - print_statement stat; - unindent () - - -(* -** GCC Attributes -*) -and print_attribute (name,args) = - if args = [] then print ( - match name with - "restrict" -> "__restrict" - (* weimer: Fri Dec 7 17:12:35 2001 - * must not print 'restrict' and the code below does allows some - * plain 'restrict's to slip though! *) - | x -> x) - else begin - print name; - print "("; if name = "__attribute__" then print "("; - (match args with - [VARIABLE "aconst"] -> print "const" - | [VARIABLE "restrict"] -> print "__restrict" - | _ -> print_commas false (fun e -> print_expression e) args); - print ")"; if name = "__attribute__" then print ")" - end - -(* Print attributes. *) -and print_attributes attrs = - List.iter (fun a -> print_attribute a; space ()) attrs - -(* -** Declaration printing -*) -and print_defs defs = - let prev = ref false in - List.iter - (fun def -> - (match def with - DECDEF _ -> prev := false - | _ -> - if not !prev then force_new_line (); - prev := true); - print_def def) - defs - -and print_def def = - match def with - FUNDEF (proto, body, loc, _) -> - comprint "fundef"; - if !printCounters then begin - try - let fname = - match proto with - (_, (n, _, _, _)) -> n - in - print_def (DECDEF (([SpecType Tint], - [(fname ^ "__counter", JUSTBASE, [], cabslu), - NO_INIT]), loc)); - with Not_found -> print "/* can't print the counter */" - end; - setLoc(loc); - print_single_name proto; - print_block body; - force_new_line (); - - | DECDEF (names, loc) -> - comprint "decdef"; - setLoc(loc); - print_init_name_group names; - print ";"; - new_line () - - | TYPEDEF (names, loc) -> - comprint "typedef"; - setLoc(loc); - print_name_group names; - print ";"; - new_line (); - force_new_line () - - | ONLYTYPEDEF (specs, loc) -> - comprint "onlytypedef"; - setLoc(loc); - print_specifiers specs; - print ";"; - new_line (); - force_new_line () - - | GLOBASM (asm, loc) -> - setLoc(loc); - print "__asm__ ("; print_string asm; print ");"; - new_line (); - force_new_line () - - | PRAGMA (a,loc) -> - setLoc(loc); - force_new_line (); - print "#pragma "; - let oldwidth = !width in - width := 1000000; (* Do not wrap pragmas *) - print_expression a; - width := oldwidth; - force_new_line () - - | LINKAGE (n, loc, dl) -> - setLoc (loc); - force_new_line (); - print "extern "; print_string n; print_string " {"; - List.iter print_def dl; - print_string "}"; - force_new_line () - - | TRANSFORMER(srcdef, destdeflist, loc) -> - setLoc(loc); - print "@transform {"; - force_new_line(); - print "{"; - force_new_line(); - indent (); - print_def srcdef; - unindent(); - print "}"; - force_new_line(); - print "to {"; - force_new_line(); - indent(); - List.iter print_def destdeflist; - unindent(); - print "}"; - force_new_line() - - | EXPRTRANSFORMER(srcexpr, destexpr, loc) -> - setLoc(loc); - print "@transformExpr { "; - print_expression srcexpr; - print " } to { "; - print_expression destexpr; - print " }"; - force_new_line() - - -(* sm: print a comment if the printComments flag is set *) -and comprint (str : string) : unit = -begin - if (!printComments) then ( - print "/*"; - print str; - print "*/ " - ) - else - () -end - -(* sm: yield either the given string, or "", depending on printComments *) -and comstring (str : string) : string = -begin - if (!printComments) then - str - else - "" -end - - -(* print abstrac_syntax -> () -** Pretty printing the given abstract syntax program. -*) -let printFile (result : out_channel) ((fname, defs) : file) = - out := result; - print_defs defs; - flush () (* sm: should do this here *) - -let set_tab t = tab := t -let set_width w = width := w - diff --git a/cil/src/frontc/frontc.ml b/cil/src/frontc/frontc.ml deleted file mode 100644 index 459ae2c..0000000 --- a/cil/src/frontc/frontc.ml +++ /dev/null @@ -1,256 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -module E = Errormsg -open Trace -open Pretty - -(* Output management *) -let out : out_channel option ref = ref None -let close_me = ref false - -let close_output _ = - match !out with - None -> () - | Some o -> begin - flush o; - if !close_me then close_out o else (); - close_me := false - end - -let set_output filename = - close_output (); - (try out := Some (open_out filename) - with (Sys_error msg) -> - output_string stderr ("Error while opening output: " ^ msg); exit 1); - close_me := true - - (* Signal that we are in MS VC mode *) -let setMSVCMode () = - Cprint.msvcMode := true - -(* filename for patching *) -let patchFileName : string ref = ref "" (* by default do no patching *) - -(* patching file contents *) -let patchFile : Cabs.file option ref = ref None - -(* whether to print the patched CABS files *) -let printPatchedFiles : bool ref = ref false - -(* whether to print a file of prototypes after parsing *) -let doPrintProtos : bool ref = ref false - -(* this seems like something that should be built-in.. *) -let isNone (o : 'a option) : bool = -begin - match o with - | Some _ -> false - | None -> true -end - -(* -** Argument definition -*) -let args : (string * Arg.spec * string) list = -[ - "--cabsonly", Arg.String set_output, ": CABS output file name"; - "--printComments", Arg.Unit (fun _ -> Cprint.printComments := true), - ": print cabs tree structure in comments in cabs output"; - "--patchFile", Arg.String (fun pf -> patchFileName := pf), - ": name the file containing patching transformations"; - "--printPatched", Arg.Unit (fun _ -> printPatchedFiles := true), - ": print patched CABS files after patching, to *.patched"; - "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true), - ": print prototypes to safec.proto.h after parsing"; -] - -exception ParseError of string -exception CabsOnly - -(* parse, and apply patching *) -let rec parse_to_cabs fname = -begin - (* parse the patch file if it isn't parsed already *) - if ((!patchFileName <> "") && (isNone !patchFile)) then ( - (* parse the patch file *) - patchFile := Some(parse_to_cabs_inner !patchFileName); - if !E.hadErrors then - (failwith "There were parsing errors in the patch file") - ); - - (* now parse the file we came here to parse *) - let cabs = parse_to_cabs_inner fname in - if !E.hadErrors then - E.s (E.error "There were parsing errors in %s\n" fname); - - (* and apply the patch file, return transformed file *) - let patched = match !patchFile with - - | Some(pf) -> ( - (* save old value of out so I can use it for debugging during patching *) - let oldOut = !out in - - (* reset out so we don't try to print the patch file to it *) - out := None; - - (trace "patch" (dprintf "newpatching %s\n" fname)); - let result = (Stats.time "newpatch" (Patch.applyPatch pf) cabs) in - - if (!printPatchedFiles) then begin - let outFname:string = fname ^ ".patched" in - (trace "patch" (dprintf "printing patched version of %s to %s\n" - fname outFname)); - let o = (open_out outFname) in - (Cprint.printFile o result); - (close_out o) - end; - - (* restore out *) - Cprint.flush (); - out := oldOut; - - result - ) - | None -> cabs - in - - (* print it ... *) - (match !out with - Some o -> begin - (trace "sm" (dprintf "writing the cabs output\n")); - output_string o ("/* Generated by Frontc */\n"); - Stats.time "printCABS" (Cprint.printFile o) patched; - close_output (); - raise CabsOnly - end - | None -> ()); - if !E.hadErrors then - raise Parsing.Parse_error; - - (* and return the patched source *) - patched -end - - -(* just parse *) -and parse_to_cabs_inner (fname : string) = - try - if !E.verboseFlag then ignore (E.log "Frontc is parsing %s\n" fname); - flush !E.logChannel; - E.hadErrors := false; - let lexbuf = Clexer.init fname in - let cabs = Stats.time "parse" (Cparser.file Clexer.initial) lexbuf in - Clexer.finish (); - (fname, cabs) - with (Sys_error msg) -> begin - ignore (E.log "Cannot open %s : %s\n" fname msg); - Clexer.finish (); - close_output (); - raise (ParseError("Cannot open " ^ fname ^ ": " ^ msg ^ "\n")) - end - | Parsing.Parse_error -> begin - ignore (E.log "Parsing error\n"); - Clexer.finish (); - close_output (); - raise (ParseError("Parse error")) - end - | e -> begin - ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e)); - Clexer.finish (); - raise e - end - - -(* print to safec.proto.h the prototypes of all functions that are defined *) -let printPrototypes ((fname, file) : Cabs.file) : unit = -begin - (*ignore (E.log "file has %d defns\n" (List.length file));*) - - let chan = open_out "safec.proto.h" in - ignore (fprintf chan "/* generated prototypes file, %d defs */\n" (List.length file)); - Cprint.out := chan; - - let counter : int ref = ref 0 in - - let rec loop (d : Cabs.definition) = begin - match d with - | Cabs.FUNDEF(name, _, loc, _) -> ( - match name with - | (_, (funcname, Cabs.PROTO(_,_,_), _, _)) -> ( - incr counter; - ignore (fprintf chan "\n/* %s from %s:%d */\n" - funcname loc.Cabs.filename loc.Cabs.lineno); - flush chan; - Cprint.print_single_name name; - Cprint.print_unescaped_string ";"; - Cprint.force_new_line (); - Cprint.flush () - ) - | _ -> () - ) - - | _ -> () - end in - (List.iter loop file); - - ignore (fprintf chan "\n/* wrote %d prototypes */\n" !counter); - close_out chan; - ignore (E.log "printed %d prototypes from %d defns to safec.proto.h\n" - !counter (List.length file)) -end - - - -let parse fname = - (trace "sm" (dprintf "parsing %s to Cabs\n" fname)); - let cabs = parse_to_cabs fname in - (* Now (return a function that will) convert to CIL *) - fun _ -> - (trace "sm" (dprintf "converting %s from Cabs to CIL\n" fname)); - let cil = Stats.time "conv" Cabs2cil.convFile cabs in - if !doPrintProtos then (printPrototypes cabs); - cil - - - - - - - - diff --git a/cil/src/frontc/frontc.mli b/cil/src/frontc/frontc.mli deleted file mode 100644 index 50ad799..0000000 --- a/cil/src/frontc/frontc.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - - (* Signal that we are in MS VC mode *) -val setMSVCMode: unit -> unit - - - (* Parse a file in *) -exception ParseError of string - - (* Raised when the front-end is requested to print the CABS and return *) -exception CabsOnly - - (* additional command line arguments *) -val args: (string * Arg.spec * string) list - - (* the main command to parse a file. Return a thunk that can be used to - * convert the AST to CIL. *) -val parse: string -> (unit -> Cil.file) - diff --git a/cil/src/frontc/lexerhack.ml b/cil/src/frontc/lexerhack.ml deleted file mode 100755 index ecae28e..0000000 --- a/cil/src/frontc/lexerhack.ml +++ /dev/null @@ -1,22 +0,0 @@ - -module E = Errormsg - -(* We provide here a pointer to a function. It will be set by the lexer and - * used by the parser. In Ocaml lexers depend on parsers, so we we have put - * such functions in a separate module. *) -let add_identifier: (string -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized add_identifier")) - -let add_type: (string -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized add_type")) - -let push_context: (unit -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized push_context")) - -let pop_context: (unit -> unit) ref = - ref (fun _ -> E.s (E.bug "You called an uninitialized pop_context")) - - -(* Keep here the current pattern for formatparse *) -let currentPattern = ref "" - diff --git a/cil/src/frontc/patch.ml b/cil/src/frontc/patch.ml deleted file mode 100644 index fcb4ba6..0000000 --- a/cil/src/frontc/patch.ml +++ /dev/null @@ -1,837 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* patch.ml *) -(* CABS file patching *) - -open Cabs -open Trace -open Pretty -open Cabsvisit - -(* binding of a unification variable to a syntactic construct *) -type binding = - | BSpecifier of string * spec_elem list - | BName of string * string - | BExpr of string * expression - -(* thrown when unification fails *) -exception NoMatch - -(* thrown when an attempt to find the associated binding fails *) -exception BadBind of string - -(* trying to isolate performance problems; will hide all the *) -(* potentially expensive debugging output behind "if verbose .." *) -let verbose : bool = true - - -(* raise NoMatch if x and y are not equal *) -let mustEq (x : 'a) (y : 'a) : unit = -begin - if (x <> y) then ( - if verbose then - (trace "patchDebug" (dprintf "mismatch by structural disequality\n")); - raise NoMatch - ) -end - -(* why isn't this in the core Ocaml library? *) -let identity x = x - - -let isPatternVar (s : string) : bool = -begin - ((String.length s) >= 1) && ((String.get s 0) = '@') -end - -(* 's' is actually "@name(blah)"; extract the 'blah' *) -let extractPatternVar (s : string) : string = - (*(trace "patch" (dprintf "extractPatternVar %s\n" s));*) - (String.sub s 6 ((String.length s) - 7)) - - -(* a few debugging printers.. *) -let printExpr (e : expression) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_expression e; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printSpec (spec: spec_elem list) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_specifiers spec; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printSpecs (pat : spec_elem list) (tgt : spec_elem list) = -begin - (printSpec pat); - (printSpec tgt) -end - -let printDecl (pat : name) (tgt : name) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_name pat; Cprint.force_new_line (); - Cprint.print_name tgt; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printDeclType (pat : decl_type) (tgt : decl_type) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_decl "__missing_field_name" pat; Cprint.force_new_line (); - Cprint.print_decl "__missing_field_name" tgt; Cprint.force_new_line (); - Cprint.flush () - ) -end - -let printDefn (d : definition) = -begin - if (verbose && traceActive "patchDebug") then ( - Cprint.print_def d; - Cprint.flush () - ) -end - - -(* class to describe how to modify the tree for subtitution *) -class substitutor (bindings : binding list) = object(self) - inherit nopCabsVisitor as super - - (* look in the binding list for a given name *) - method findBinding (name : string) : binding = - begin - try - (List.find - (fun b -> - match b with - | BSpecifier(n, _) -> n=name - | BName(n, _) -> n=name - | BExpr(n, _) -> n=name) - bindings) - with - Not_found -> raise (BadBind ("name not found: " ^ name)) - end - - method vexpr (e:expression) : expression visitAction = - begin - match e with - | EXPR_PATTERN(name) -> ( - match (self#findBinding name) with - | BExpr(_, expr) -> ChangeTo(expr) (* substitute bound expression *) - | _ -> raise (BadBind ("wrong type: " ^ name)) - ) - | _ -> DoChildren - end - - (* use of a name *) - method vvar (s:string) : string = - begin - if (isPatternVar s) then ( - let nameString = (extractPatternVar s) in - match (self#findBinding nameString) with - | BName(_, str) -> str (* substitute *) - | _ -> raise (BadBind ("wrong type: " ^ nameString)) - ) - else - s - end - - (* binding introduction of a name *) - method vname (k: nameKind) (spec: specifier) (n: name) : name visitAction = - begin - match n with (s (*variable name*), dtype, attrs, loc) -> ( - let replacement = (self#vvar s) in (* use replacer from above *) - if (s <> replacement) then - ChangeTo(replacement, dtype, attrs, loc) - else - DoChildren (* no replacement *) - ) - end - - method vspec (specList: specifier) : specifier visitAction = - begin - if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n")); - (printSpec specList); - - (* are any of the specifiers SpecPatterns? we have to check the entire *) - (* list, not just the head, because e.g. "typedef @specifier(foo)" has *) - (* "typedef" as the head of the specifier list *) - if (List.exists (fun elt -> match elt with - | SpecPattern(_) -> true - | _ -> false) - specList) then begin - (* yes, replace the existing list with one got by *) - (* replacing all occurrences of SpecPatterns *) - (trace "patchDebug" (dprintf "at least one spec pattern\n")); - ChangeTo - (List.flatten - (List.map - (* for each specifier element, yield the specifier list *) - (* to which it maps; then we'll flatten the final result *) - (fun elt -> - match elt with - | SpecPattern(name) -> ( - match (self#findBinding name) with - | BSpecifier(_, replacement) -> ( - (trace "patchDebug" (dprintf "replacing pattern %s\n" name)); - replacement - ) - | _ -> raise (BadBind ("wrong type: " ^ name)) - ) - | _ -> [elt] (* leave this one alone *) - ) - specList - ) - ) - end - else - (* none of the specifiers in specList are patterns *) - DoChildren - end - - method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction = - begin - match tspec with - | Tnamed(str) when (isPatternVar str) -> - ChangeTo(Tnamed(self#vvar str)) - | Tstruct(str, fields, extraAttrs) when (isPatternVar str) -> ( - (trace "patchDebug" (dprintf "substituting %s\n" str)); - ChangeDoChildrenPost(Tstruct((self#vvar str), fields, extraAttrs), identity) - ) - | Tunion(str, fields, extraAttrs) when (isPatternVar str) -> - (trace "patchDebug" (dprintf "substituting %s\n" str)); - ChangeDoChildrenPost(Tunion((self#vvar str), fields, extraAttrs), identity) - | _ -> DoChildren - end - -end - - -(* why can't I have forward declarations in the language?!! *) -let unifyExprFwd : (expression -> expression -> binding list) ref - = ref (fun e e -> []) - - -(* substitution for expressions *) -let substExpr (bindings : binding list) (expr : expression) : expression = -begin - if verbose then - (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings))); - (printExpr expr); - - (* apply the transformation *) - let result = (visitCabsExpression (new substitutor bindings :> cabsVisitor) expr) in - (printExpr result); - - result -end - -let d_loc (_:unit) (loc: cabsloc) : doc = - text loc.filename ++ chr ':' ++ num loc.lineno - - -(* class to describe how to modify the tree when looking for places *) -(* to apply expression transformers *) -class exprTransformer (srcpattern : expression) (destpattern : expression) - (patchline : int) (srcloc : cabsloc) = object(self) - inherit nopCabsVisitor as super - - method vexpr (e:expression) : expression visitAction = - begin - (* see if the source pattern matches this subexpression *) - try ( - let bindings = (!unifyExprFwd srcpattern e) in - - (* match! *) - (trace "patch" (dprintf "expr match: patch line %d, src %a\n" - patchline d_loc srcloc)); - ChangeTo(substExpr bindings destpattern) - ) - - with NoMatch -> ( - (* doesn't apply *) - DoChildren - ) - end - - (* other constructs left unchanged *) -end - - -let unifyList (pat : 'a list) (tgt : 'a list) - (unifyElement : 'a -> 'a -> binding list) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyList (pat len %d, tgt len %d)\n" - (List.length pat) (List.length tgt))); - - (* walk down the lists *) - let rec loop pat tgt : binding list = - match pat, tgt with - | [], [] -> [] - | (pelt :: prest), (telt :: trest) -> - (unifyElement pelt telt) @ - (loop prest trest) - | _,_ -> ( - (* no match *) - if verbose then ( - (trace "patchDebug" (dprintf "mismatching list length\n")); - ); - raise NoMatch - ) - in - (loop pat tgt) -end - - -let gettime () : float = - (Unix.times ()).Unix.tms_utime - -let rec applyPatch (patchFile : file) (srcFile : file) : file = -begin - let patch : definition list = (snd patchFile) in - let srcFname : string = (fst srcFile) in - let src : definition list = (snd srcFile) in - - (trace "patchTime" (dprintf "applyPatch start: %f\n" (gettime ()))); - if (traceActive "patchDebug") then - Cprint.out := stdout (* hack *) - else (); - - (* more hackery *) - unifyExprFwd := unifyExpr; - - (* patch a single source definition, yield transformed *) - let rec patchDefn (patch : definition list) (d : definition) : definition list = - begin - match patch with - | TRANSFORMER(srcpattern, destpattern, loc) :: rest -> ( - if verbose then - (trace "patchDebug" - (dprintf "considering applying defn pattern at line %d to src at %a\n" - loc.lineno d_loc (get_definitionloc d))); - - (* see if the source pattern matches the definition 'd' we have *) - try ( - let bindings = (unifyDefn srcpattern d) in - - (* we have a match! apply the substitutions *) - (trace "patch" (dprintf "defn match: patch line %d, src %a\n" - loc.lineno d_loc (get_definitionloc d))); - - (List.map (fun destElt -> (substDefn bindings destElt)) destpattern) - ) - - with NoMatch -> ( - (* no match, continue down list *) - (*(trace "patch" (dprintf "no match\n"));*) - (patchDefn rest d) - ) - ) - - | EXPRTRANSFORMER(srcpattern, destpattern, loc) :: rest -> ( - if verbose then - (trace "patchDebug" - (dprintf "considering applying expr pattern at line %d to src at %a\n" - loc.lineno d_loc (get_definitionloc d))); - - (* walk around in 'd' looking for expressions to modify *) - let dList = (visitCabsDefinition - ((new exprTransformer srcpattern destpattern - loc.lineno (get_definitionloc d)) - :> cabsVisitor) - d - ) in - - (* recursively invoke myself to try additional patches *) - (* since visitCabsDefinition might return a list, I'll try my *) - (* addtional patches on every yielded definition, then collapse *) - (* all of them into a single list *) - (List.flatten (List.map (fun d -> (patchDefn rest d)) dList)) - ) - - | _ :: rest -> ( - (* not a transformer; just keep going *) - (patchDefn rest d) - ) - | [] -> ( - (* reached the end of the patch file with no match *) - [d] (* have to wrap it in a list ... *) - ) - end in - - (* transform all the definitions *) - let result : definition list = - (List.flatten (List.map (fun d -> (patchDefn patch d)) src)) in - - (*Cprint.print_defs result;*) - - if (traceActive "patchDebug") then ( - (* avoid flush bug? yes *) - Cprint.force_new_line (); - Cprint.flush () - ); - - (trace "patchTime" (dprintf "applyPatch finish: %f\n" (gettime ()))); - (srcFname, result) -end - - -(* given a definition pattern 'pat', and a target concrete defintion 'tgt', *) -(* determine if they can be unified; if so, return the list of bindings of *) -(* unification variables in pat; otherwise raise NoMatch *) -and unifyDefn (pat : definition) (tgt : definition) : binding list = -begin - match pat, tgt with - | DECDEF((pspecifiers, pdeclarators), _), - DECDEF((tspecifiers, tdeclarators), _) -> ( - if verbose then - (trace "patchDebug" (dprintf "unifyDefn of DECDEFs\n")); - (unifySpecifiers pspecifiers tspecifiers) @ - (unifyInitDeclarators pdeclarators tdeclarators) - ) - - | TYPEDEF((pspec, pdecl), _), - TYPEDEF((tspec, tdecl), _) -> ( - if verbose then - (trace "patchDebug" (dprintf "unifyDefn of TYPEDEFs\n")); - (unifySpecifiers pspec tspec) @ - (unifyDeclarators pdecl tdecl) - ) - - | ONLYTYPEDEF(pspec, _), - ONLYTYPEDEF(tspec, _) -> ( - if verbose then - (trace "patchDebug" (dprintf "unifyDefn of ONLYTYPEDEFs\n")); - (unifySpecifiers pspec tspec) - ) - - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching definitions\n")); - raise NoMatch - ) -end - -and unifySpecifier (pat : spec_elem) (tgt : spec_elem) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifySpecifier\n")); - (printSpecs [pat] [tgt]); - - if (pat = tgt) then [] else - - match pat, tgt with - | SpecType(tspec1), SpecType(tspec2) -> - (unifyTypeSpecifier tspec1 tspec2) - | SpecPattern(name), _ -> - (* record that future occurrances of @specifier(name) will yield this specifier *) - if verbose then - (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); - [BSpecifier(name, [tgt])] - | _,_ -> ( - (* no match *) - if verbose then ( - (trace "patchDebug" (dprintf "mismatching specifiers\n")); - ); - raise NoMatch - ) -end - -and unifySpecifiers (pat : spec_elem list) (tgt : spec_elem list) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifySpecifiers\n")); - (printSpecs pat tgt); - - (* canonicalize the specifiers by sorting them *) - let pat' = (List.stable_sort compare pat) in - let tgt' = (List.stable_sort compare tgt) in - - (* if they are equal, they match with no further checking *) - if (pat' = tgt') then [] else - - (* walk down the lists; don't walk the sorted lists because the *) - (* pattern must always be last, if it occurs *) - let rec loop pat tgt : binding list = - match pat, tgt with - | [], [] -> [] - | [SpecPattern(name)], _ -> - (* final SpecPattern matches anything which comes after *) - (* record that future occurrences of @specifier(name) will yield this specifier *) - if verbose then - (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); - [BSpecifier(name, tgt)] - | (pspec :: prest), (tspec :: trest) -> - (unifySpecifier pspec tspec) @ - (loop prest trest) - | _,_ -> ( - (* no match *) - if verbose then ( - (trace "patchDebug" (dprintf "mismatching specifier list length\n")); - ); - raise NoMatch - ) - in - (loop pat tgt) -end - -and unifyTypeSpecifier (pat: typeSpecifier) (tgt: typeSpecifier) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyTypeSpecifier\n")); - - if (pat = tgt) then [] else - - match pat, tgt with - | Tnamed(s1), Tnamed(s2) -> (unifyString s1 s2) - | Tstruct(name1, None, _), Tstruct(name2, None, _) -> - (unifyString name1 name2) - | Tstruct(name1, Some(fields1), _), Tstruct(name2, Some(fields2), _) -> - (* ignoring extraAttrs b/c we're just trying to come up with a list - * of substitutions, and there's no unify_attributes function, and - * I don't care at this time about checking that they are equal .. *) - (unifyString name1 name2) @ - (unifyList fields1 fields2 unifyField) - | Tunion(name1, None, _), Tstruct(name2, None, _) -> - (unifyString name1 name2) - | Tunion(name1, Some(fields1), _), Tunion(name2, Some(fields2), _) -> - (unifyString name1 name2) @ - (unifyList fields1 fields2 unifyField) - | Tenum(name1, None, _), Tenum(name2, None, _) -> - (unifyString name1 name2) - | Tenum(name1, Some(items1), _), Tenum(name2, Some(items2), _) -> - (mustEq items1 items2); (* enum items *) - (unifyString name1 name2) - | TtypeofE(exp1), TtypeofE(exp2) -> - (unifyExpr exp1 exp2) - | TtypeofT(spec1, dtype1), TtypeofT(spec2, dtype2) -> - (unifySpecifiers spec1 spec2) @ - (unifyDeclType dtype1 dtype2) - | _ -> ( - if verbose then (trace "patchDebug" (dprintf "mismatching typeSpecifiers\n")); - raise NoMatch - ) -end - -and unifyField (pat : field_group) (tgt : field_group) : binding list = -begin - match pat,tgt with (spec1, list1), (spec2, list2) -> ( - (unifySpecifiers spec1 spec2) @ - (unifyList list1 list2 unifyNameExprOpt) - ) -end - -and unifyNameExprOpt (pat : name * expression option) - (tgt : name * expression option) : binding list = -begin - match pat,tgt with - | (name1, None), (name2, None) -> (unifyName name1 name2) - | (name1, Some(exp1)), (name2, Some(exp2)) -> - (unifyName name1 name2) @ - (unifyExpr exp1 exp2) - | _,_ -> [] -end - -and unifyName (pat : name) (tgt : name) : binding list = -begin - match pat,tgt with (pstr, pdtype, pattrs, ploc), (tstr, tdtype, tattrs, tloc) -> - (mustEq pattrs tattrs); - (unifyString pstr tstr) @ - (unifyDeclType pdtype tdtype) -end - -and unifyInitDeclarators (pat : init_name list) (tgt : init_name list) : binding list = -begin - (* - if verbose then - (trace "patchDebug" (dprintf "unifyInitDeclarators, pat %d, tgt %d\n" - (List.length pat) (List.length tgt))); - *) - - match pat, tgt with - | ((pdecl, piexpr) :: prest), - ((tdecl, tiexpr) :: trest) -> - (unifyDeclarator pdecl tdecl) @ - (unifyInitExpr piexpr tiexpr) @ - (unifyInitDeclarators prest trest) - | [], [] -> [] - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching init declarators\n")); - raise NoMatch - ) -end - -and unifyDeclarators (pat : name list) (tgt : name list) : binding list = - (unifyList pat tgt unifyDeclarator) - -and unifyDeclarator (pat : name) (tgt : name) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyDeclarator\n")); - (printDecl pat tgt); - - match pat, tgt with - | (pname, pdtype, pattr, ploc), - (tname, tdtype, tattr, tloc) -> - (mustEq pattr tattr); - (unifyDeclType pdtype tdtype) @ - (unifyString pname tname) -end - -and unifyDeclType (pat : decl_type) (tgt : decl_type) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifyDeclType\n")); - (printDeclType pat tgt); - - match pat, tgt with - | JUSTBASE, JUSTBASE -> [] - | PARENTYPE(pattr1, ptype, pattr2), - PARENTYPE(tattr1, ttype, tattr2) -> - (mustEq pattr1 tattr1); - (mustEq pattr2 tattr2); - (unifyDeclType ptype ttype) - | ARRAY(ptype, pattr, psz), - ARRAY(ttype, tattr, tsz) -> - (mustEq pattr tattr); - (unifyDeclType ptype ttype) @ - (unifyExpr psz tsz) - | PTR(pattr, ptype), - PTR(tattr, ttype) -> - (mustEq pattr tattr); - (unifyDeclType ptype ttype) - | PROTO(ptype, pformals, pva), - PROTO(ttype, tformals, tva) -> - (mustEq pva tva); - (unifyDeclType ptype ttype) @ - (unifySingleNames pformals tformals) - | _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching decl_types\n")); - raise NoMatch - ) -end - -and unifySingleNames (pat : single_name list) (tgt : single_name list) : binding list = -begin - if verbose then - (trace "patchDebug" (dprintf "unifySingleNames, pat %d, tgt %d\n" - (List.length pat) (List.length tgt))); - - match pat, tgt with - | [], [] -> [] - | (pspec, pdecl) :: prest, - (tspec, tdecl) :: trest -> - (unifySpecifiers pspec tspec) @ - (unifyDeclarator pdecl tdecl) @ - (unifySingleNames prest trest) - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching single_name lists\n")); - raise NoMatch - ) -end - -and unifyString (pat : string) (tgt : string) : binding list = -begin - (* equal? match with no further ado *) - if (pat = tgt) then [] else - - (* is the pattern a variable? *) - if (isPatternVar pat) then - (* pat is actually "@name(blah)"; extract the 'blah' *) - let varname = (extractPatternVar pat) in - - (* when substituted, this name becomes 'tgt' *) - if verbose then - (trace "patchDebug" (dprintf "found name match for %s\n" varname)); - [BName(varname, tgt)] - - else ( - if verbose then - (trace "patchDebug" (dprintf "mismatching names: %s and %s\n" pat tgt)); - raise NoMatch - ) -end - -and unifyExpr (pat : expression) (tgt : expression) : binding list = -begin - (* if they're equal, that's good enough *) - if (pat = tgt) then [] else - - (* shorter name *) - let ue = unifyExpr in - - (* because of the equality check above, I can omit some cases *) - match pat, tgt with - | UNARY(pop, pexpr), - UNARY(top, texpr) -> - (mustEq pop top); - (ue pexpr texpr) - | BINARY(pop, pexp1, pexp2), - BINARY(top, texp1, texp2) -> - (mustEq pop top); - (ue pexp1 texp1) @ - (ue pexp2 texp2) - | QUESTION(p1, p2, p3), - QUESTION(t1, t2, t3) -> - (ue p1 t1) @ - (ue p2 t2) @ - (ue p3 t3) - | CAST((pspec, ptype), piexpr), - CAST((tspec, ttype), tiexpr) -> - (mustEq ptype ttype); - (unifySpecifiers pspec tspec) @ - (unifyInitExpr piexpr tiexpr) - | CALL(pfunc, pargs), - CALL(tfunc, targs) -> - (ue pfunc tfunc) @ - (unifyExprs pargs targs) - | COMMA(pexprs), - COMMA(texprs) -> - (unifyExprs pexprs texprs) - | EXPR_SIZEOF(pexpr), - EXPR_SIZEOF(texpr) -> - (ue pexpr texpr) - | TYPE_SIZEOF(pspec, ptype), - TYPE_SIZEOF(tspec, ttype) -> - (mustEq ptype ttype); - (unifySpecifiers pspec tspec) - | EXPR_ALIGNOF(pexpr), - EXPR_ALIGNOF(texpr) -> - (ue pexpr texpr) - | TYPE_ALIGNOF(pspec, ptype), - TYPE_ALIGNOF(tspec, ttype) -> - (mustEq ptype ttype); - (unifySpecifiers pspec tspec) - | INDEX(parr, pindex), - INDEX(tarr, tindex) -> - (ue parr tarr) @ - (ue pindex tindex) - | MEMBEROF(pexpr, pfield), - MEMBEROF(texpr, tfield) -> - (mustEq pfield tfield); - (ue pexpr texpr) - | MEMBEROFPTR(pexpr, pfield), - MEMBEROFPTR(texpr, tfield) -> - (mustEq pfield tfield); - (ue pexpr texpr) - | GNU_BODY(pblock), - GNU_BODY(tblock) -> - (mustEq pblock tblock); - [] - | EXPR_PATTERN(name), _ -> - (* match, and contribute binding *) - if verbose then - (trace "patchDebug" (dprintf "found expr match for %s\n" name)); - [BExpr(name, tgt)] - | a, b -> - if (verbose && traceActive "patchDebug") then ( - (trace "patchDebug" (dprintf "mismatching expression\n")); - (printExpr a); - (printExpr b) - ); - raise NoMatch -end - -and unifyInitExpr (pat : init_expression) (tgt : init_expression) : binding list = -begin - (* - Cprint.print_init_expression pat; Cprint.force_new_line (); - Cprint.print_init_expression tgt; Cprint.force_new_line (); - Cprint.flush (); - *) - - match pat, tgt with - | NO_INIT, NO_INIT -> [] - | SINGLE_INIT(pe), SINGLE_INIT(te) -> - (unifyExpr pe te) - | COMPOUND_INIT(plist), - COMPOUND_INIT(tlist) -> ( - let rec loop plist tlist = - match plist, tlist with - | ((pwhat, piexpr) :: prest), - ((twhat, tiexpr) :: trest) -> - (mustEq pwhat twhat); - (unifyInitExpr piexpr tiexpr) @ - (loop prest trest) - | [], [] -> [] - | _, _ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching compound init exprs\n")); - raise NoMatch - ) - in - (loop plist tlist) - ) - | _,_ -> ( - if verbose then - (trace "patchDebug" (dprintf "mismatching init exprs\n")); - raise NoMatch - ) -end - -and unifyExprs (pat : expression list) (tgt : expression list) : binding list = - (unifyList pat tgt unifyExpr) - - -(* given the list of bindings 'b', substitute them into 'd' to yield a new definition *) -and substDefn (bindings : binding list) (defn : definition) : definition = -begin - if verbose then - (trace "patchDebug" (dprintf "substDefn with %d bindings\n" (List.length bindings))); - (printDefn defn); - - (* apply the transformation *) - match (visitCabsDefinition (new substitutor bindings :> cabsVisitor) defn) with - | [d] -> d (* expect a singleton list *) - | _ -> (failwith "didn't get a singleton list where I expected one") -end - - -(* end of file *) diff --git a/cil/src/frontc/patch.mli b/cil/src/frontc/patch.mli deleted file mode 100644 index 4f32870..0000000 --- a/cil/src/frontc/patch.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - -(* patch.mli *) -(* interface for patch.ml *) - -val applyPatch : Cabs.file -> Cabs.file -> Cabs.file diff --git a/cil/src/libmaincil.ml b/cil/src/libmaincil.ml deleted file mode 100644 index 952c013..0000000 --- a/cil/src/libmaincil.ml +++ /dev/null @@ -1,108 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* libmaincil *) -(* this is a replacement for maincil.ml, for the case when we're - * creating a C-callable library (libcil.a); all it does is register - * a couple of functions and initialize CIL *) - - -module E = Errormsg - -open Cil - - -(* print a Cil 'file' to stdout *) -let unparseToStdout (cil : file) : unit = -begin - dumpFile defaultCilPrinter stdout cil -end;; - -(* a visitor to unroll all types - may need to do some magic to keep attributes *) -class unrollVisitorClass = object (self) - inherit nopCilVisitor - - (* variable declaration *) - method vvdec (vi : varinfo) : varinfo visitAction = - begin - vi.vtype <- unrollTypeDeep vi.vtype; - (*ignore (E.log "varinfo for %s in file '%s' line %d byte %d\n" vi.vname vi.vdecl.file vi.vdecl.line vi.vdecl.byte);*) - SkipChildren - end - - (* global: need to unroll fields of compinfo *) - method vglob (g : global) : global list visitAction = - begin - match g with - GCompTag(ci, loc) as g -> - let doFieldinfo (fi : fieldinfo) : unit = - fi.ftype <- unrollTypeDeep fi.ftype - in begin - ignore(List.map doFieldinfo ci.cfields); - (*ChangeTo [g]*) - SkipChildren - end - | _ -> DoChildren - end -end;; - - -let unrollVisitor = new unrollVisitorClass;; - -(* open and parse a C file into a Cil 'file', unroll all typedefs *) -let parseOneFile (fname: string) : file = - let ast : file = Frontc.parse fname () in - begin - visitCilFile unrollVisitor ast; - ast - end -;; - -let getDummyTypes () : typ * typ = - ( TPtr(TVoid [], []), TInt(IInt, []) ) -;; - -(* register some functions - these may be called from C code *) -Callback.register "cil_parse" parseOneFile; -Callback.register "cil_unparse" unparseToStdout; -(* Callback.register "unroll_type_deep" unrollTypeDeep; *) -Callback.register "get_dummy_types" getDummyTypes; - -(* initalize CIL *) -initCIL (); - - diff --git a/cil/src/machdep.c b/cil/src/machdep.c deleted file mode 100644 index 1134865..0000000 --- a/cil/src/machdep.c +++ /dev/null @@ -1,220 +0,0 @@ -/* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - */ - -#include "../config.h" - -#include - -#ifdef HAVE_STDLIB_H -#include -#endif - -#ifdef HAVE_WCHAR_H -#include -#endif - -#ifdef _GNUCC -#define LONGLONG long long -#define CONST_STRING_LITERALS "true" -#define VERSION __VERSION__ -#define VERSION_MAJOR __GNUC__ -#define VERSION_MINOR __GNUC_MINOR__ -#endif - -#ifdef _MSVC -#define LONGLONG __int64 -#define CONST_STRING_LITERALS "false" -#define VERSION "0" -#define VERSION_MAJOR 0 -#define VERSION_MINOR 0 -#endif - -/* The type for the machine dependency structure is generated from the - Makefile */ -int main() { - fprintf(stderr, "Generating machine dependency information for CIL\n"); - - printf("(* Generated by code in %s *)\n", __FILE__); - printf("\t version_major = %d;\n", VERSION_MAJOR); - printf("\t version_minor = %d;\n", VERSION_MINOR); - printf("\t version = \"%s\";\n", VERSION); - // Size of certain types - printf("\t sizeof_short = %d;\n", sizeof(short)); - printf("\t sizeof_int = %d;\n", sizeof(int)); - printf("\t sizeof_long = %d;\n", sizeof(long)); - printf("\t sizeof_longlong = %d;\n", sizeof(LONGLONG)); - printf("\t sizeof_ptr = %d;\n", sizeof(int *)); - printf("\t sizeof_enum = %d;\n", sizeof(enum e { ONE, TWO })); - printf("\t sizeof_float = %d;\n", sizeof(float)); - printf("\t sizeof_double = %d;\n", sizeof(double)); - printf("\t sizeof_longdouble = %d;\n", sizeof(long double)); - printf("\t sizeof_sizeof = %d;\n", sizeof(sizeof(int))); - printf("\t sizeof_wchar = %d;\n", sizeof(wchar_t)); - printf("\t sizeof_void = %d;\n", sizeof(void)); - printf("\t sizeof_fun = %d;\n", -#ifdef __GNUC__ - sizeof(main) -#else - 0 -#endif - ); - - // The alignment of a short - { - struct shortstruct { - char c; - short s; - }; - printf("\t alignof_short = %d;\n", - (int)(&((struct shortstruct*)0)->s)); - } - - // The alignment of an int - { - struct intstruct { - char c; - int i; - }; - printf("\t alignof_int = %d;\n", - (int)(&((struct intstruct*)0)->i)); - } - - // The alignment of a long - { - struct longstruct { - char c; - long l; - }; - printf("\t alignof_long = %d;\n", - (int)(&((struct longstruct*)0)->l)); - } - - // The alignment of long long - { - struct longlong { - char c; - LONGLONG ll; - }; - printf("\t alignof_longlong = %d;\n", - (int)(&((struct longlong*)0)->ll)); - } - - // The alignment of a ptr - { - struct ptrstruct { - char c; - int * p; - }; - printf("\t alignof_ptr = %d;\n", - (int)(&((struct ptrstruct*)0)->p)); - } - - // The alignment of an enum - { - struct enumstruct { - char c; - enum e2 { THREE, FOUR, FIVE } e; - }; - printf("\t alignof_enum = %d;\n", - (int)(&((struct enumstruct*)0)->e)); - } - - // The alignment of a float - { - struct floatstruct { - char c; - float f; - }; - printf("\t alignof_float = %d;\n", - (int)(&((struct floatstruct*)0)->f)); - } - - // The alignment of double - { - struct s1 { - char c; - double d; - }; - printf("\t alignof_double = %d;\n", - (int)(&((struct s1*)0)->d)); - } - - // The alignment of long double - { - struct s1 { - char c; - long double ld; - }; - printf("\t alignof_longdouble = %d;\n", - (int)(&((struct s1*)0)->ld)); - } - - printf("\t alignof_str = %d;\n", -#ifdef __GNUC__ - __alignof("a string") -#else - 0 -#endif - ); - - printf("\t alignof_fun = %d;\n", -#ifdef __GNUC__ - __alignof(main) -#else - 0 -#endif - ); - - // Whether char is unsigned - printf("\t char_is_unsigned = %s;\n", - ((char)0xff) > 0 ? "true" : "false"); - - - // Whether string literals contain constant characters - puts("\t const_string_literals = " CONST_STRING_LITERALS ";"); - - - // endianity - { - int e = 0x11223344; - printf("\t little_endian = %s;\n", - (0x44 == *(char*)&e) ? "true" : - ((0x11 == *(char*)&e) ? "false" : (exit(1), "false"))); - } - - exit(0); -} diff --git a/cil/src/main.ml b/cil/src/main.ml deleted file mode 100644 index bbdb730..0000000 --- a/cil/src/main.ml +++ /dev/null @@ -1,288 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* maincil *) -(* this module is the program entry point for the 'cilly' program, *) -(* which reads a C program file, parses it, translates it to the CIL *) -(* intermediate language, and then renders that back into C *) - - -module F = Frontc -module C = Cil -module CK = Check -module E = Errormsg -open Pretty -open Trace - -type outfile = - { fname: string; - fchan: out_channel } -let outChannel : outfile option ref = ref None -let mergedChannel : outfile option ref = ref None - - -let parseOneFile (fname: string) : C.file = - (* PARSE and convert to CIL *) - if !Cilutil.printStages then ignore (E.log "Parsing %s\n" fname); - let cil = F.parse fname () in - - if (not !Epicenter.doEpicenter) then ( - (* sm: remove unused temps to cut down on gcc warnings *) - (* (Stats.time "usedVar" Rmtmps.removeUnusedTemps cil); *) - (trace "sm" (dprintf "removing unused temporaries\n")); - (Rmtmps.removeUnusedTemps cil) - ); - cil - -(** These are the statically-configured features. To these we append the - * features defined in Feature_config.ml (from Makefile) *) - -let makeCFGFeature : C.featureDescr = - { C.fd_name = "makeCFG"; - C.fd_enabled = Cilutil.makeCFG; - C.fd_description = "make the program look more like a CFG" ; - C.fd_extraopt = []; - C.fd_doit = (fun f -> - ignore (Partial.calls_end_basic_blocks f) ; - ignore (Partial.globally_unique_vids f) ; - Cil.iterGlobals f (fun glob -> match glob with - Cil.GFun(fd,_) -> Cil.prepareCFG fd ; - (* jc: blockinggraph depends on this "true" arg *) - ignore (Cil.computeCFGInfo fd true) - | _ -> ()) - ); - C.fd_post_check = true; - } - -let features : C.featureDescr list = - [ Epicenter.feature; - Simplify.feature; - Canonicalize.feature; - Callgraph.feature; - Logwrites.feature; - Heapify.feature1; - Heapify.feature2; - Oneret.feature; - makeCFGFeature; (* ww: make CFG *must* come before Partial *) - Partial.feature; - Simplemem.feature; - Sfi.feature; - Dataslicing.feature; - Logcalls.feature; - Ptranal.feature; - Liveness.feature; - ] - @ Feature_config.features - -let rec processOneFile (cil: C.file) = - begin - - if !Cilutil.doCheck then begin - ignore (E.log "First CIL check\n"); - ignore (CK.checkFile [] cil); - end; - - (* Scan all the features configured from the Makefile and, if they are - * enabled then run them on the current file *) - List.iter - (fun fdesc -> - if ! (fdesc.C.fd_enabled) then begin - if !E.verboseFlag then - ignore (E.log "Running CIL feature %s (%s)\n" - fdesc.C.fd_name fdesc.C.fd_description); - (* Run the feature, and see how long it takes. *) - Stats.time fdesc.C.fd_name - fdesc.C.fd_doit cil; - (* See if we need to do some checking *) - if !Cilutil.doCheck && fdesc.C.fd_post_check then begin - ignore (E.log "CIL check after %s\n" fdesc.C.fd_name); - ignore (CK.checkFile [] cil); - end - end) - features; - - - (match !outChannel with - None -> () - | Some c -> Stats.time "printCIL" - (C.dumpFile (!C.printerForMaincil) c.fchan c.fname) cil); - - if !E.hadErrors then - E.s (E.error "Error while processing file; see above for details."); - - end - -(***** MAIN *****) -let rec theMain () = - let usageMsg = "Usage: cilly [options] source-files" in - (* Processign of output file arguments *) - let openFile (what: string) (takeit: outfile -> unit) (fl: string) = - if !E.verboseFlag then - ignore (Printf.printf "Setting %s to %s\n" what fl); - (try takeit { fname = fl; - fchan = open_out fl } - with _ -> - raise (Arg.Bad ("Cannot open " ^ what ^ " file " ^ fl))) - in - let outName = ref "" in - (* sm: enabling this by default, since I think usually we - * want 'cilly' transformations to preserve annotations; I - * can easily add a command-line flag if someone sometimes - * wants these suppressed *) - C.print_CIL_Input := true; - - (*********** COMMAND LINE ARGUMENTS *****************) - (* Construct the arguments for the features configured from the Makefile *) - let blankLine = ("", Arg.Unit (fun _ -> ()), "") in - let featureArgs = - List.fold_right - (fun fdesc acc -> - if !(fdesc.C.fd_enabled) then - (* The feature is enabled by default *) - blankLine :: - ("--dont" ^ fdesc.C.fd_name, Arg.Clear(fdesc.C.fd_enabled), - " Disable " ^ fdesc.C.fd_description) :: - fdesc.C.fd_extraopt @ acc - else - (* Disabled by default *) - blankLine :: - ("--do" ^ fdesc.C.fd_name, Arg.Set(fdesc.C.fd_enabled), - " Enable " ^ fdesc.C.fd_description) :: - fdesc.C.fd_extraopt @ acc - ) - features - [blankLine] - in - let featureArgs = - ("", Arg.Unit (fun () -> ()), "\n\t\tCIL Features") :: featureArgs - in - - let argDescr = Ciloptions.options @ - [ - "--out", Arg.String (openFile "output" - (fun oc -> outChannel := Some oc)), - "the name of the output CIL file. The cilly script sets this for you."; - "--mergedout", Arg.String (openFile "merged output" - (fun oc -> mergedChannel := Some oc)), - "specify the name of the merged file"; - ] - @ F.args @ featureArgs in - begin - (* this point in the code is the program entry point *) - - Stats.reset (Stats.has_performance_counters ()); - - (* parse the command-line arguments *) - Arg.parse argDescr Ciloptions.recordFile usageMsg; - Cil.initCIL (); - - Ciloptions.fileNames := List.rev !Ciloptions.fileNames; - - if !Cilutil.testcil <> "" then begin - Testcil.doit !Cilutil.testcil - end else - (* parse each of the files named on the command line, to CIL *) - let files = List.map parseOneFile !Ciloptions.fileNames in - - (* if there's more than one source file, merge them together; *) - (* now we have just one CIL "file" to deal with *) - let one = - match files with - [one] -> one - | [] -> E.s (E.error "No arguments for CIL\n") - | _ -> - let merged = - Stats.time "merge" (Mergecil.merge files) - (if !outName = "" then "stdout" else !outName) in - if !E.hadErrors then - E.s (E.error "There were errors during merging\n"); - (* See if we must save the merged file *) - (match !mergedChannel with - None -> () - | Some mc -> begin - let oldpci = !C.print_CIL_Input in - C.print_CIL_Input := true; - Stats.time "printMerged" - (C.dumpFile !C.printerForMaincil mc.fchan mc.fname) merged; - C.print_CIL_Input := oldpci - end); - merged - in - - if !E.hadErrors then - E.s (E.error "Cabs2cil had some errors"); - - (* process the CIL file (merged if necessary) *) - processOneFile one - end -;; - (* Define a wrapper for main to - * intercept the exit *) -let failed = ref false - -let cleanup () = - if !E.verboseFlag || !Cilutil.printStats then - Stats.print stderr "Timings:\n"; - if !E.logChannel != stderr then - close_out (! E.logChannel); - (match ! outChannel with Some c -> close_out c.fchan | _ -> ()) - - -(* Without this handler, cilly.asm.exe will quit silently with return code 0 - when a segfault happens. *) -let handleSEGV code = - if !Cil.currentLoc == Cil.locUnknown then - E.log "**** Segmentation fault (possibly a stack overflow)\n" - else begin - E.log ("**** Segmentation fault (possibly a stack overflow) "^^ - "while processing %a\n") - Cil.d_loc !Cil.currentLoc - end; - exit code - -let _ = Sys.set_signal Sys.sigsegv (Sys.Signal_handle handleSEGV); - -;; - -begin - try - theMain (); - with F.CabsOnly -> (* this is OK *) () -end; -cleanup (); -exit (if !failed then 1 else 0) - diff --git a/cil/src/mergecil.ml b/cil/src/mergecil.ml deleted file mode 100644 index dee519e..0000000 --- a/cil/src/mergecil.ml +++ /dev/null @@ -1,1770 +0,0 @@ -(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* mergecil.ml *) -(* This module is responsible for merging multiple CIL source trees into - * a single, coherent CIL tree which contains the union of all the - * definitions in the source files. It effectively acts like a linker, - * but at the source code level instead of the object code level. *) - - -module P = Pretty -open Cil -module E = Errormsg -module H = Hashtbl -module A = Alpha -open Trace - -let debugMerge = false -let debugInlines = false - -let ignore_merge_conflicts = ref false - -(* Try to merge structure with the same name. However, do not complain if - * they are not the same *) -let mergeSynonyms = true - - -(** Whether to use path compression *) -let usePathCompression = false - -(* Try to merge definitions of inline functions. They can appear in multiple - * files and we would like them all to be the same. This can slow down the - * merger an order of magnitude !!! *) -let mergeInlines = true - -let mergeInlinesRepeat = mergeInlines && true - -let mergeInlinesWithAlphaConvert = mergeInlines && true - -(* when true, merge duplicate definitions of externally-visible functions; - * this uses a mechanism which is faster than the one for inline functions, - * but only probabilistically accurate *) -let mergeGlobals = true - - -(* Return true if 's' starts with the prefix 'p' *) -let prefix p s = - let lp = String.length p in - let ls = String.length s in - lp <= ls && String.sub s 0 lp = p - - - -(* A name is identified by the index of the file in which it occurs (starting - * at 0 with the first file) and by the actual name. We'll keep name spaces - * separate *) - -(* We define a data structure for the equivalence classes *) -type 'a node = - { nname: string; (* The actual name *) - nfidx: int; (* The file index *) - ndata: 'a; (* Data associated with the node *) - mutable nloc: (location * int) option; - (* location where defined and index within the file of the definition. - * If None then it means that this node actually DOES NOT appear in the - * given file. In rare occasions we need to talk in a given file about - * types that are not defined in that file. This happens with undefined - * structures but also due to cross-contamination of types in a few of - * the cases of combineType (see the definition of combineTypes). We - * try never to choose as representatives nodes without a definition. - * We also choose as representative the one that appears earliest *) - mutable nrep: 'a node; (* A pointer to another node in its class (one - * closer to the representative). The nrep node - * is always in an earlier file, except for the - * case where a name is undefined in one file - * and defined in a later file. If this pointer - * points to the node itself then this is the - * representative. *) - mutable nmergedSyns: bool (* Whether we have merged the synonyms for - * the node of this name *) - } - -let d_nloc () (lo: (location * int) option) : P.doc = - match lo with - None -> P.text "None" - | Some (l, idx) -> P.dprintf "Some(%d at %a)" idx d_loc l - -(* Make a node with a self loop. This is quite tricky. *) -let mkSelfNode (eq: (int * string, 'a node) H.t) (* The equivalence table *) - (syn: (string, 'a node) H.t) (* The synonyms table *) - (fidx: int) (name: string) (data: 'a) - (l: (location * int) option) = - let res = { nname = name; nfidx = fidx; ndata = data; nloc = l; - nrep = Obj.magic 1; nmergedSyns = false; } in - res.nrep <- res; (* Make the self cycle *) - H.add eq (fidx, name) res; (* Add it to the proper table *) - if mergeSynonyms && not (prefix "__anon" name) then - H.add syn name res; - res - -let debugFind = false - -(* Find the representative with or without path compression *) -let rec find (pathcomp: bool) (nd: 'a node) = - if debugFind then - ignore (E.log " find %s(%d)\n" nd.nname nd.nfidx); - if nd.nrep == nd then begin - if debugFind then - ignore (E.log " = %s(%d)\n" nd.nname nd.nfidx); - nd - end else begin - let res = find pathcomp nd.nrep in - if usePathCompression && pathcomp && nd.nrep != res then - nd.nrep <- res; (* Compress the paths *) - res - end - - -(* Union two nodes and return the new representative. We prefer as the - * representative a node defined earlier. We try not to use as - * representatives nodes that are not defined in their files. We return a - * function for undoing the union. Make sure that between the union and the - * undo you do not do path compression *) -let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = - (* Move to the representatives *) - let nd1 = find true nd1 in - let nd2 = find true nd2 in - if nd1 == nd2 then begin - (* It can happen that we are trying to union two nodes that are already - * equivalent. This is because between the time we check that two nodes - * are not already equivalent and the time we invoke the union operation - * we check type isomorphism which might change the equivalence classes *) -(* - ignore (warn "unioning already equivalent nodes for %s(%d)" - nd1.nname nd1.nfidx); -*) - nd1, fun x -> x - end else begin - let rep, norep = (* Choose the representative *) - if (nd1.nloc != None) = (nd2.nloc != None) then - (* They have the same defined status. Choose the earliest *) - if nd1.nfidx < nd2.nfidx then nd1, nd2 - else if nd1.nfidx > nd2.nfidx then nd2, nd1 - else (* In the same file. Choose the one with the earliest index *) begin - match nd1.nloc, nd2.nloc with - Some (_, didx1), Some (_, didx2) -> - if didx1 < didx2 then nd1, nd2 else - if didx1 > didx2 then nd2, nd1 - else begin - ignore (warn - "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file" - nd1.nname nd2.nname nd1.nfidx didx1); - nd1, nd2 - end - | _, _ -> (* both none. Does not matter which one we choose. Should - * not happen though. *) - (* sm: it does happen quite a bit when, e.g. merging STLport with - * some client source; I'm disabling the warning since it supposedly - * is harmless anyway, so is useless noise *) - (* sm: re-enabling on claim it now will probably not happen *) - ignore (warn "Merging two undefined elements in the same file: %s and %s\n" nd1.nname nd2.nname); - nd1, nd2 - end - else (* One is defined, the other is not. Choose the defined one *) - if nd1.nloc != None then nd1, nd2 else nd2, nd1 - in - let oldrep = norep.nrep in - norep.nrep <- rep; - rep, (fun () -> norep.nrep <- oldrep) - end -(* -let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = - if nd1 == nd2 && nd1.nname = "!!!intEnumInfo!!!" then begin - ignore (warn "unioning two identical nodes for %s(%d)" - nd1.nname nd1.nfidx); - nd1, fun x -> x - end else - union nd1 nd2 -*) -(* Find the representative for a node and compress the paths in the process *) -let findReplacement - (pathcomp: bool) - (eq: (int * string, 'a node) H.t) - (fidx: int) - (name: string) : ('a * int) option = - if debugFind then - ignore (E.log "findReplacement for %s(%d)\n" name fidx); - try - let nd = H.find eq (fidx, name) in - if nd.nrep == nd then begin - if debugFind then - ignore (E.log " is a representative\n"); - None (* No replacement if this is the representative of its class *) - end else - let rep = find pathcomp nd in - if rep != rep.nrep then - E.s (bug "find does not return the representative\n"); - if debugFind then - ignore (E.log " RES = %s(%d)\n" rep.nname rep.nfidx); - Some (rep.ndata, rep.nfidx) - with Not_found -> begin - if debugFind then - ignore (E.log " not found in the map\n"); - None - end - -(* Make a node if one does not already exist. Otherwise return the - * representative *) -let getNode (eq: (int * string, 'a node) H.t) - (syn: (string, 'a node) H.t) - (fidx: int) (name: string) (data: 'a) - (l: (location * int) option) = - let debugGetNode = false in - if debugGetNode then - ignore (E.log "getNode(%s(%d), %a)\n" - name fidx d_nloc l); - try - let res = H.find eq (fidx, name) in - - (match res.nloc, l with - (* Maybe we have a better location now *) - None, Some _ -> res.nloc <- l - | Some (old_l, old_idx), Some (l, idx) -> - if old_idx != idx then - ignore (warn "Duplicate definition of node %s(%d) at indices %d(%a) and %d(%a)" - name fidx old_idx d_loc old_l idx d_loc l) - else - () - - | _, _ -> ()); - if debugGetNode then - ignore (E.log " node already found\n"); - find false res (* No path compression *) - with Not_found -> begin - let res = mkSelfNode eq syn fidx name data l in - if debugGetNode then - ignore (E.log " made a new one\n"); - res - end - - - -(* Dump a graph *) -let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit = - ignore (E.log "Equivalence graph for %s is:\n" what); - H.iter (fun (fidx, name) nd -> - ignore (E.log " %s(%d) %s-> " - name fidx (if nd.nloc = None then "(undef)" else "")); - if nd.nrep == nd then - ignore (E.log "*\n") - else - ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx )) - eq - - - - -(* For each name space we define a set of equivalence classes *) -let vEq: (int * string, varinfo node) H.t = H.create 111 (* Vars *) -let sEq: (int * string, compinfo node) H.t = H.create 111 (* Struct + union *) -let eEq: (int * string, enuminfo node) H.t = H.create 111 (* Enums *) -let tEq: (int * string, typeinfo node) H.t = H.create 111 (* Type names*) -let iEq: (int * string, varinfo node) H.t = H.create 111 (* Inlines *) - -(* Sometimes we want to merge synonyms. We keep some tables indexed by names. - * Each name is mapped to multiple exntries *) -let vSyn: (string, varinfo node) H.t = H.create 111 (* Not actually used *) -let iSyn: (string, varinfo node) H.t = H.create 111 (* Inlines *) -let sSyn: (string, compinfo node) H.t = H.create 111 -let eSyn: (string, enuminfo node) H.t = H.create 111 -let tSyn: (string, typeinfo node) H.t = H.create 111 - -(** A global environment for variables. Put in here only the non-static - * variables, indexed by their name. *) -let vEnv : (string, varinfo node) H.t = H.create 111 - - -(* A set of inline functions indexed by their printout ! *) -let inlineBodies : (P.doc, varinfo node) H.t = H.create 111 - -(** A number of alpha conversion tables. We ought to keep one table for each - * name space. Unfortunately, because of the way the C lexer works, type - * names must be different from variable names!! We one alpha table both for - * variables and types. *) -let vtAlpha : (string, location A.alphaTableData ref) H.t - = H.create 57 (* Variables and - * types *) -let sAlpha : (string, location A.alphaTableData ref) H.t - = H.create 57 (* Structures and - * unions have - * the same name - * space *) -let eAlpha : (string, location A.alphaTableData ref) H.t - = H.create 57 (* Enumerations *) - - -(** Keep track, for all global function definitions, of the names of the formal - * arguments. They might change during merging of function types if the - * prototype occurs after the function definition and uses different names. - * We'll restore the names at the end *) -let formalNames: (int * string, string list) H.t = H.create 111 - - -(* Accumulate here the globals in the merged file *) -let theFileTypes = ref [] -let theFile = ref [] - -(* add 'g' to the merged file *) -let mergePushGlobal (g: global) : unit = - pushGlobal g ~types:theFileTypes ~variables:theFile - -let mergePushGlobals gl = List.iter mergePushGlobal gl - - -(* The index of the current file being scanned *) -let currentFidx = ref 0 - -let currentDeclIdx = ref 0 (* The index of the definition in a file. This is - * maintained both in pass 1 and in pass 2. Make - * sure you count the same things in both passes. *) -(* Keep here the file names *) -let fileNames : (int, string) H.t = H.create 113 - - - -(* Remember the composite types that we have already declared *) -let emittedCompDecls: (string, bool) H.t = H.create 113 -(* Remember the variables also *) -let emittedVarDecls: (string, bool) H.t = H.create 113 - -(* also keep track of externally-visible function definitions; - * name maps to declaration, location, and semantic checksum *) -let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113 -(* and same for variable definitions; name maps to GVar fields *) -let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113 - -(** A mapping from the new names to the original names. Used in PASS2 when we - * rename variables. *) -let originalVarNames: (string, string) H.t = H.create 113 - -(* Initialize the module *) -let init () = - H.clear sAlpha; - H.clear eAlpha; - H.clear vtAlpha; - - H.clear vEnv; - - H.clear vEq; - H.clear sEq; - H.clear eEq; - H.clear tEq; - H.clear iEq; - - H.clear vSyn; - H.clear sSyn; - H.clear eSyn; - H.clear tSyn; - H.clear iSyn; - - theFile := []; - theFileTypes := []; - - H.clear formalNames; - H.clear inlineBodies; - - currentFidx := 0; - currentDeclIdx := 0; - H.clear fileNames; - - H.clear emittedVarDecls; - H.clear emittedCompDecls; - - H.clear emittedFunDefn; - H.clear emittedVarDefn; - - H.clear originalVarNames - - -(* Some enumerations have to be turned into an integer. We implement this by - * introducing a special enumeration type which we'll recognize later to be - * an integer *) -let intEnumInfo = - { ename = "!!!intEnumInfo!!!"; (* This is otherwise invalid *) - eitems = []; - eattr = []; - ereferenced = false; - } -(* And add it to the equivalence graph *) -let intEnumInfoNode = - getNode eEq eSyn 0 intEnumInfo.ename intEnumInfo - (Some (locUnknown, 0)) - - (* Combine the types. Raises the Failure exception with an error message. - * isdef says whether the new type is for a definition *) -type combineWhat = - CombineFundef (* The new definition is for a function definition. The old - * is for a prototype *) - | CombineFunarg (* Comparing a function argument type with an old prototype - * arg *) - | CombineFunret (* Comparing the return of a function with that from an old - * prototype *) - | CombineOther - - -let rec combineTypes (what: combineWhat) - (oldfidx: int) (oldt: typ) - (fidx: int) (t: typ) : typ = - match oldt, t with - | TVoid olda, TVoid a -> TVoid (addAttributes olda a) - | TInt (oldik, olda), TInt (ik, a) -> - let combineIK oldk k = - if oldk == k then oldk else - (* GCC allows a function definition to have a more precise integer - * type than a prototype that says "int" *) - if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 - && (what = CombineFunarg || what = CombineFunret) - then - k - else ( - let msg = - P.sprint ~width:80 - (P.dprintf - "(different integer types %a and %a)" - d_type oldt d_type t) in - raise (Failure msg) - ) - in - TInt (combineIK oldik ik, addAttributes olda a) - - | TFloat (oldfk, olda), TFloat (fk, a) -> - let combineFK oldk k = - if oldk == k then oldk else - (* GCC allows a function definition to have a more precise integer - * type than a prototype that says "double" *) - if not !msvcMode && oldk = FDouble && k = FFloat - && (what = CombineFunarg || what = CombineFunret) - then - k - else - raise (Failure "(different floating point types)") - in - TFloat (combineFK oldfk fk, addAttributes olda a) - - | TEnum (oldei, olda), TEnum (ei, a) -> - (* Matching enumerations always succeeds. But sometimes it maps both - * enumerations to integers *) - matchEnumInfo oldfidx oldei fidx ei; - TEnum (oldei, addAttributes olda a) - - - (* Strange one. But seems to be handled by GCC *) - | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, - addAttributes olda a) - - (* Strange one. But seems to be handled by GCC. Warning. Here we are - * leaking types from new to old *) - | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a) - - | TComp (oldci, olda) , TComp (ci, a) -> - matchCompInfo oldfidx oldci fidx ci; - (* If we get here we were successful *) - TComp (oldci, addAttributes olda a) - - | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> - let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in - let combinesz = - match oldsz, sz with - None, Some _ -> sz - | Some _, None -> oldsz - | None, None -> oldsz - | Some oldsz', Some sz' -> - let samesz = - match constFold true oldsz', constFold true sz' with - Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i - | _, _ -> false - in - if samesz then oldsz else - raise (Failure "(different array sizes)") - in - TArray (combbt, combinesz, addAttributes olda a) - - | TPtr (oldbt, olda), TPtr (bt, a) -> - TPtr (combineTypes CombineOther oldfidx oldbt fidx bt, - addAttributes olda a) - - (* WARNING: In this case we are leaking types from new to old !! *) - | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t - - - | TFun _, TFun (_, _, _, [Attr("missingproto",_)]) -> oldt - - | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> - let newrt = - combineTypes - (if what = CombineFundef then CombineFunret else CombineOther) - oldfidx oldrt fidx rt - in - if oldva != va then - raise (Failure "(diferent vararg specifiers)"); - (* If one does not have arguments, believe the one with the - * arguments *) - let newargs = - if oldargs = None then args else - if args = None then oldargs else - let oldargslist = argsToList oldargs in - let argslist = argsToList args in - if List.length oldargslist <> List.length argslist then - raise (Failure "(different number of arguments)") - else begin - (* Go over the arguments and update the old ones with the - * adjusted types *) - Some - (List.map2 - (fun (on, ot, oa) (an, at, aa) -> - let n = if an <> "" then an else on in - let t = - combineTypes - (if what = CombineFundef then - CombineFunarg else CombineOther) - oldfidx ot fidx at - in - let a = addAttributes oa aa in - (n, t, a)) - oldargslist argslist) - end - in - TFun (newrt, newargs, oldva, addAttributes olda a) - - | TBuiltin_va_list olda, TBuiltin_va_list a -> - TBuiltin_va_list (addAttributes olda a) - - | TNamed (oldt, olda), TNamed (t, a) -> - matchTypeInfo oldfidx oldt fidx t; - (* If we get here we were able to match *) - TNamed(oldt, addAttributes olda a) - - (* Unroll first the new type *) - | _, TNamed (t, a) -> - let res = combineTypes what oldfidx oldt fidx t.ttype in - typeAddAttributes a res - - (* And unroll the old type as well if necessary *) - | TNamed (oldt, a), _ -> - let res = combineTypes what oldfidx oldt.ttype fidx t in - typeAddAttributes a res - - | _ -> ( - (* raise (Failure "(different type constructors)") *) - let msg:string = (P.sprint 1000 (P.dprintf "(different type constructors: %a vs. %a)" - d_type oldt d_type t)) in - raise (Failure msg) - ) - - -(* Match two compinfos and throw a Failure if they do not match *) -and matchCompInfo (oldfidx: int) (oldci: compinfo) - (fidx: int) (ci: compinfo) : unit = - if oldci.cstruct <> ci.cstruct then - raise (Failure "(different struct/union types)"); - (* See if we have a mapping already *) - (* Make the nodes if not already made. Actually return the - * representatives *) - let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci None in - let cinode = getNode sEq sSyn fidx ci.cname ci None in - if oldcinode == cinode then (* We already know they are the same *) - () - else begin - (* Replace with the representative data *) - let oldci = oldcinode.ndata in - let oldfidx = oldcinode.nfidx in - let ci = cinode.ndata in - let fidx = cinode.nfidx in - - let old_len = List.length oldci.cfields in - let len = List.length ci.cfields in - (* It is easy to catch here the case when the new structure is undefined - * and the old one was defined. We just reuse the old *) - (* More complicated is the case when the old one is not defined but the - * new one is. We still reuse the old one and we'll take care of defining - * it later with the new fields. - * GN: 7/10/04, I could not find when is "later", so I added it below *) - if len <> 0 && old_len <> 0 && old_len <> len then ( - let curLoc = !currentLoc in (* d_global blows this away.. *) - (trace "merge" (P.dprintf "different # of fields\n%d: %a\n%d: %a\n" - old_len d_global (GCompTag(oldci,locUnknown)) - len d_global (GCompTag(ci,locUnknown)) - )); - currentLoc := curLoc; - let msg = Printf.sprintf - "(different number of fields in %s and %s: %d != %d.)" - oldci.cname ci.cname old_len len in - raise (Failure msg) - ); - (* We check that they are defined in the same way. While doing this there - * might be recursion and we have to watch for going into an infinite - * loop. So we add the assumption that they are equal *) - let newrep, undo = union oldcinode cinode in - (* We check the fields but watch for Failure. We only do the check when - * the lengths are the same. Due to the code above this the other - * possibility is that one of the length is 0, in which case we reuse the - * old compinfo. *) - (* But what if the old one is the empty one ? *) - if old_len = len then begin - (try - List.iter2 - (fun oldf f -> - if oldf.fbitfield <> f.fbitfield then - raise (Failure "(different bitfield info)"); - if oldf.fattr <> f.fattr then - raise (Failure "(different field attributes)"); - (* Make sure the types are compatible *) - let newtype = - combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype - in - (* Change the type in the representative *) - oldf.ftype <- newtype; - ) - oldci.cfields ci.cfields - with Failure reason -> begin - (* Our assumption was wrong. Forget the isomorphism *) - undo (); - let msg = - P.sprint ~width:80 - (P.dprintf - "\n\tFailed assumption that %s and %s are isomorphic %s@!%a@!%a" - (compFullName oldci) (compFullName ci) reason - dn_global (GCompTag(oldci,locUnknown)) - dn_global (GCompTag(ci,locUnknown))) - in - raise (Failure msg) - end) - end else begin - (* We will reuse the old one. One of them is empty. If the old one is - * empty, copy over the fields from the new one. Won't this result in - * all sorts of undefined types??? *) - if old_len = 0 then - oldci.cfields <- ci.cfields; - end; - (* We get here when we succeeded checking that they are equal, or one of - * them was empty *) - newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr; - () - end - -(* Match two enuminfos and throw a Failure if they do not match *) -and matchEnumInfo (oldfidx: int) (oldei: enuminfo) - (fidx: int) (ei: enuminfo) : unit = - (* Find the node for this enum, no path compression. *) - let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in - let einode = getNode eEq eSyn fidx ei.ename ei None in - if oldeinode == einode then (* We already know they are the same *) - () - else begin - (* Replace with the representative data *) - let oldei = oldeinode.ndata in - let ei = einode.ndata in - (* Try to match them. But if you cannot just make them both integers *) - try - (* We do not have a mapping. They better be defined in the same way *) - if List.length oldei.eitems <> List.length ei.eitems then - raise (Failure "(different number of enumeration elements)"); - (* We check that they are defined in the same way. This is a fairly - * conservative check. *) - List.iter2 - (fun (old_iname, old_iv, _) (iname, iv, _) -> - if old_iname <> iname then - raise (Failure "(different names for enumeration items)"); - let samev = - match constFold true old_iv, constFold true iv with - Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i - | _ -> false - in - if not samev then - raise (Failure "(different values for enumeration items)")) - oldei.eitems ei.eitems; - (* Set the representative *) - let newrep, _ = union oldeinode einode in - (* We get here if the enumerations match *) - newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr; - () - with Failure msg -> begin - (* Get here if you cannot merge two enumeration nodes *) - if oldeinode != intEnumInfoNode then begin - let _ = union oldeinode intEnumInfoNode in () - end; - if einode != intEnumInfoNode then begin - let _ = union einode intEnumInfoNode in () - end; - end - end - - -(* Match two typeinfos and throw a Failure if they do not match *) -and matchTypeInfo (oldfidx: int) (oldti: typeinfo) - (fidx: int) (ti: typeinfo) : unit = - if oldti.tname = "" || ti.tname = "" then - E.s (bug "matchTypeInfo for anonymous type\n"); - (* Find the node for this enum, no path compression. *) - let oldtnode = getNode tEq tSyn oldfidx oldti.tname oldti None in - let tnode = getNode tEq tSyn fidx ti.tname ti None in - if oldtnode == tnode then (* We already know they are the same *) - () - else begin - (* Replace with the representative data *) - let oldti = oldtnode.ndata in - let oldfidx = oldtnode.nfidx in - let ti = tnode.ndata in - let fidx = tnode.nfidx in - (* Check that they are the same *) - (try - ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype); - with Failure reason -> begin - let msg = - P.sprint ~width:80 - (P.dprintf - "\n\tFailed assumption that %s and %s are isomorphic %s" - oldti.tname ti.tname reason) in - raise (Failure msg) - end); - let _ = union oldtnode tnode in - () - end - -(* Scan all files and do two things *) -(* 1. Initialize the alpha renaming tables with the names of the globals so - * that when we come in the second pass to generate new names, we do not run - * into conflicts. *) -(* 2. For all declarations of globals unify their types. In the process - * construct a set of equivalence classes on type names, structure and - * enumeration tags *) -(* 3. We clean the referenced flags *) - -let rec oneFilePass1 (f:file) : unit = - H.add fileNames !currentFidx f.fileName; - if debugMerge || !E.verboseFlag then - ignore (E.log "Pre-merging (%d) %s\n" !currentFidx f.fileName); - currentDeclIdx := 0; - if f.globinitcalled || f.globinit <> None then - E.s (E.warn "Merging file %s has global initializer" f.fileName); - - (* We scan each file and we look at all global varinfo. We see if globals - * with the same name have been encountered before and we merge those types - * *) - let matchVarinfo (vi: varinfo) (l: location * int) = - ignore (Alpha.registerAlphaName vtAlpha None vi.vname !currentLoc); - (* Make a node for it and put it in vEq *) - let vinode = mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in - try - let oldvinode = find true (H.find vEnv vi.vname) in - let oldloc, _ = - match oldvinode.nloc with - None -> E.s (bug "old variable is undefined") - | Some l -> l - in - let oldvi = oldvinode.ndata in - (* There is an old definition. We must combine the types. Do this first - * because it might fail *) - let newtype = - try - combineTypes CombineOther - oldvinode.nfidx oldvi.vtype - !currentFidx vi.vtype; - with (Failure reason) -> begin - (* Go ahead *) - let f = if !ignore_merge_conflicts then warn else error in - ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s " - vi.vname (H.find fileNames !currentFidx) !currentFidx - d_loc oldloc - (H.find fileNames oldvinode.nfidx) oldvinode.nfidx - reason); - raise Not_found - end - in - let newrep, _ = union oldvinode vinode in - (* We do not want to turn non-"const" globals into "const" one. That - * can happen if one file declares the variable a non-const while - * others declare it as "const". *) - if hasAttribute "const" (typeAttrs vi.vtype) != - hasAttribute "const" (typeAttrs oldvi.vtype) then begin - newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype; - end else begin - newrep.ndata.vtype <- newtype; - end; - (* clean up the storage. *) - let newstorage = - if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then - oldvi.vstorage - else if oldvi.vstorage = Extern then vi.vstorage - (* Sometimes we turn the NoStorage specifier into Static for inline - * functions *) - else if oldvi.vstorage = Static && - vi.vstorage = NoStorage then Static - else begin - ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a" - vi.vname d_storage vi.vstorage d_storage oldvi.vstorage - d_loc oldloc); - vi.vstorage - end - in - newrep.ndata.vstorage <- newstorage; - newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr; - () - with Not_found -> (* Not present in the previous files. Remember it for - * later *) - H.add vEnv vi.vname vinode - - in - List.iter - (function - | GVarDecl (vi, l) | GVar (vi, _, l) -> - currentLoc := l; - incr currentDeclIdx; - vi.vreferenced <- false; - if vi.vstorage <> Static then begin - matchVarinfo vi (l, !currentDeclIdx); - end - - | GFun (fdec, l) -> - currentLoc := l; - incr currentDeclIdx; - (* Save the names of the formal arguments *) - let _, args, _, _ = splitFunctionTypeVI fdec.svar in - H.add formalNames (!currentFidx, fdec.svar.vname) - (List.map (fun (fn, _, _) -> fn) (argsToList args)); - fdec.svar.vreferenced <- false; - (* Force inline functions to be static. *) - (* GN: This turns out to be wrong. inline functions are external, - * unless specified to be static. *) - (* - if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then - fdec.svar.vstorage <- Static; - *) - if fdec.svar.vstorage <> Static then begin - matchVarinfo fdec.svar (l, !currentDeclIdx) - end else begin - if fdec.svar.vinline && mergeInlines then - (* Just create the nodes for inline functions *) - ignore (getNode iEq iSyn !currentFidx - fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx))) - end - (* Make nodes for the defined type and structure tags *) - | GType (t, l) -> - incr currentDeclIdx; - t.treferenced <- false; - if t.tname <> "" then (* The empty names are just for introducing - * undefined comp tags *) - ignore (getNode tEq tSyn !currentFidx t.tname t - (Some (l, !currentDeclIdx))) - else begin (* Go inside and clean the referenced flag for the - * declared tags *) - match t.ttype with - TComp (ci, _) -> - ci.creferenced <- false; - (* Create a node for it *) - ignore (getNode sEq sSyn !currentFidx ci.cname ci None) - - | TEnum (ei, _) -> - ei.ereferenced <- false; - ignore (getNode eEq eSyn !currentFidx ei.ename ei None); - - | _ -> E.s (bug "Anonymous Gtype is not TComp") - end - - | GCompTag (ci, l) -> - incr currentDeclIdx; - ci.creferenced <- false; - ignore (getNode sEq sSyn !currentFidx ci.cname ci - (Some (l, !currentDeclIdx))) - | GEnumTag (ei, l) -> - incr currentDeclIdx; - ei.ereferenced <- false; - ignore (getNode eEq eSyn !currentFidx ei.ename ei - (Some (l, !currentDeclIdx))) - - | _ -> ()) - f.globals - - -(* Try to merge synonyms. Do not give an error if they fail to merge *) -let doMergeSynonyms - (syn : (string, 'a node) H.t) - (eq : (int * string, 'a node) H.t) - (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that - * throws Failure if no match *) - : unit = - H.iter (fun n node -> - if not node.nmergedSyns then begin - (* find all the nodes for the same name *) - let all = H.find_all syn n in - let rec tryone (classes: 'a node list) (* A number of representatives - * for this name *) - (nd: 'a node) : 'a node list (* Returns an expanded set - * of classes *) = - nd.nmergedSyns <- true; - (* Compare in turn with all the classes we have so far *) - let rec compareWithClasses = function - [] -> [nd](* No more classes. Add this as a new class *) - | c :: restc -> - try - compare c.nfidx c.ndata nd.nfidx nd.ndata; - (* Success. Stop here the comparison *) - c :: restc - with Failure _ -> (* Failed. Try next class *) - c :: (compareWithClasses restc) - in - compareWithClasses classes - in - (* Start with an empty set of classes for this name *) - let _ = List.fold_left tryone [] all in - () - end) - syn - - -let matchInlines (oldfidx: int) (oldi: varinfo) - (fidx: int) (i: varinfo) = - let oldinode = getNode iEq iSyn oldfidx oldi.vname oldi None in - let inode = getNode iEq iSyn fidx i.vname i None in - if oldinode == inode then - () - else begin - (* Replace with the representative data *) - let oldi = oldinode.ndata in - let oldfidx = oldinode.nfidx in - let i = inode.ndata in - let fidx = inode.nfidx in - (* There is an old definition. We must combine the types. Do this first - * because it might fail *) - oldi.vtype <- - combineTypes CombineOther - oldfidx oldi.vtype fidx i.vtype; - (* We get here if we have success *) - (* Combine the attributes as well *) - oldi.vattr <- addAttributes oldi.vattr i.vattr; - (* Do not union them yet because we do not know that they are the same. - * We have checked only the types so far *) - () - end - -(************************************************************ - * - * PASS 2 - * - * - ************************************************************) - -(** Keep track of the functions we have used already in the file. We need - * this to avoid removing an inline function that has been used already. - * This can only occur if the inline function is defined after it is used - * already; a bad style anyway *) -let varUsedAlready: (string, unit) H.t = H.create 111 - -(** A visitor that renames uses of variables and types *) -class renameVisitorClass = object (self) - inherit nopCilVisitor - - (* This is either a global variable which we took care of, or a local - * variable. Must do its type and attributes. *) - method vvdec (vi: varinfo) = DoChildren - - (* This is a variable use. See if we must change it *) - method vvrbl (vi: varinfo) : varinfo visitAction = - if not vi.vglob then DoChildren else - if vi.vreferenced then begin - H.add varUsedAlready vi.vname (); - DoChildren - end else begin - match findReplacement true vEq !currentFidx vi.vname with - None -> DoChildren - | Some (vi', oldfidx) -> - if debugMerge then - ignore (E.log "Renaming use of var %s(%d) to %s(%d)\n" - vi.vname !currentFidx vi'.vname oldfidx); - vi'.vreferenced <- true; - H.add varUsedAlready vi'.vname (); - ChangeTo vi' - end - - - (* The use of a type. Change only those types whose underlying info - * is not a root. *) - method vtype (t: typ) = - match t with - TComp (ci, a) when not ci.creferenced -> begin - match findReplacement true sEq !currentFidx ci.cname with - None -> DoChildren - | Some (ci', oldfidx) -> - if debugMerge then - ignore (E.log "Renaming use of %s(%d) to %s(%d)\n" - ci.cname !currentFidx ci'.cname oldfidx); - ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a)) - end - | TEnum (ei, a) when not ei.ereferenced -> begin - match findReplacement true eEq !currentFidx ei.ename with - None -> DoChildren - | Some (ei', _) -> - if ei' == intEnumInfo then - (* This is actually our friend intEnumInfo *) - ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a)) - else - ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a)) - end - - | TNamed (ti, a) when not ti.treferenced -> begin - match findReplacement true tEq !currentFidx ti.tname with - None -> DoChildren - | Some (ti', _) -> - ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a)) - end - - | _ -> DoChildren - - (* The Field offset might need to be changed to use new compinfo *) - method voffs = function - Field (f, o) -> begin - (* See if the compinfo was changed *) - if f.fcomp.creferenced then - DoChildren - else begin - match findReplacement true sEq !currentFidx f.fcomp.cname with - None -> DoChildren (* We did not replace it *) - | Some (ci', oldfidx) -> begin - (* First, find out the index of the original field *) - let rec indexOf (i: int) = function - [] -> - E.s (bug "Cannot find field %s in %s(%d)\n" - f.fname (compFullName f.fcomp) !currentFidx) - | f' :: rest when f' == f -> i - | _ :: rest -> indexOf (i + 1) rest - in - let index = indexOf 0 f.fcomp.cfields in - if List.length ci'.cfields <= index then - E.s (bug "Too few fields in replacement %s(%d) for %s(%d)\n" - (compFullName ci') oldfidx - (compFullName f.fcomp) !currentFidx); - let f' = List.nth ci'.cfields index in - ChangeDoChildrenPost (Field (f', o), fun x -> x) - end - end - end - | _ -> DoChildren - - method vinitoffs o = - (self#voffs o) (* treat initializer offsets same as lvalue offsets *) - -end - -let renameVisitor = new renameVisitorClass - - -(** A visitor that renames uses of inline functions that were discovered in - * pass 2 to be used before they are defined. This is like the renameVisitor - * except it only looks at the variables (thus it is a bit more efficient) - * and it also renames forward declarations of the inlines to be removed. *) - -class renameInlineVisitorClass = object (self) - inherit nopCilVisitor - - (* This is a variable use. See if we must change it *) - method vvrbl (vi: varinfo) : varinfo visitAction = - if not vi.vglob then DoChildren else - if vi.vreferenced then begin (* Already renamed *) - DoChildren - end else begin - match findReplacement true vEq !currentFidx vi.vname with - None -> DoChildren - | Some (vi', oldfidx) -> - if debugMerge then - ignore (E.log "Renaming var %s(%d) to %s(%d)\n" - vi.vname !currentFidx vi'.vname oldfidx); - vi'.vreferenced <- true; - ChangeTo vi' - end - - (* And rename some declarations of inlines to remove. We cannot drop this - * declaration (see small1/combineinline6) *) - method vglob = function - GVarDecl(vi, l) when vi.vinline -> begin - (* Get the original name *) - let origname = - try H.find originalVarNames vi.vname - with Not_found -> vi.vname - in - (* Now see if this must be replaced *) - match findReplacement true vEq !currentFidx origname with - None -> DoChildren - | Some (vi', _) -> ChangeTo [GVarDecl (vi', l)] - end - | _ -> DoChildren - -end -let renameInlinesVisitor = new renameInlineVisitorClass - - -(* sm: First attempt at a semantic checksum for function bodies. - * Ideally, two function's checksums would be equal only when their - * bodies were provably equivalent; but I'm using a much simpler and - * less accurate heuristic here. It should be good enough for the - * purpose I have in mind, which is doing duplicate removal of - * multiply-instantiated template functions. *) -let functionChecksum (dec: fundec) : int = -begin - (* checksum the structure of the statements (only) *) - let rec stmtListSum (lst : stmt list) : int = - (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst) - and stmtSum (s: stmt) : int = - (* strategy is to just throw a lot of prime numbers into the - * computation in hopes of avoiding accidental collision.. *) - match s.skind with - | Instr(l) -> 13 + 67*(List.length l) - | Return(_) -> 17 - | Goto(_) -> 19 - | Break(_) -> 23 - | Continue(_) -> 29 - | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts) - + 41*(stmtListSum b2.bstmts) - | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts) - (* don't look at stmt list b/c is not part of tree *) -(* - | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts) -*) - | While(_,b,_) -> 49 + 53*(stmtListSum b.bstmts) - | DoWhile(_,b,_) -> 49 + 53*(stmtListSum b.bstmts) - | For(_,_,_,b,_) -> 49 + 53*(stmtListSum b.bstmts) - | Block(b) -> 59 + 61*(stmtListSum b.bstmts) - | TryExcept (b, (il, e), h, _) -> - 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts) - | TryFinally (b, h, _) -> - 103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts) - in - - (* disabled 2nd and 3rd measure because they appear to get different - * values, for the same code, depending on whether the code was just - * parsed into CIL or had previously been parsed into CIL, printed - * out, then re-parsed into CIL *) - let a,b,c,d,e = - (List.length dec.sformals), (* # formals *) - 0 (*(List.length dec.slocals)*), (* # locals *) - 0 (*dec.smaxid*), (* estimate of internal statement count *) - (List.length dec.sbody.bstmts), (* number of statements at outer level *) - (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *) - (*(trace "sm" (P.dprintf "sum: %s is %d %d %d %d %d\n"*) - (* dec.svar.vname a b c d e));*) - 2*a + 3*b + 5*c + 7*d + 11*e -end - - -(* sm: equality for initializers, etc.; this is like '=', except - * when we reach shared pieces (like references into the type - * structure), we use '==', to prevent circularity *) -(* update: that's no good; I'm using this to find things which - * are equal but from different CIL trees, so nothing will ever - * be '=='.. as a hack I'll just change those places to 'true', - * so these functions are not now checking proper equality.. - * places where equality is not complete are marked "INC" *) -let rec equalInits (x: init) (y: init) : bool = -begin - match x,y with - | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye) - | CompoundInit(xt, xoil), CompoundInit(yt, yoil) -> - (*(xt == yt) &&*) (* INC *) (* types need to be identically equal *) - let rec equalLists xoil yoil : bool = - match xoil,yoil with - | ((xo,xi) :: xrest), ((yo,yi) :: yrest) -> - (equalOffsets xo yo) && - (equalInits xi yi) && - (equalLists xrest yrest) - | [], [] -> true - | _, _ -> false - in - (equalLists xoil yoil) - | _, _ -> false -end - -and equalOffsets (x: offset) (y: offset) : bool = -begin - match x,y with - | NoOffset, NoOffset -> true - | Field(xfi,xo), Field(yfi,yo) -> - (xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *) - (equalOffsets xo yo) - | Index(xe,xo), Index(ye,yo) -> - (equalExps xe ye) && - (equalOffsets xo yo) - | _,_ -> false -end - -and equalExps (x: exp) (y: exp) : bool = -begin - match x,y with - | Const(xc), Const(yc) -> xc = yc || (* safe to use '=' on literals *) - ( - (* CIL changes (unsigned)0 into 0U during printing.. *) - match xc,yc with - | CInt64(xv,_,_),CInt64(yv,_,_) -> - (Int64.to_int xv) = 0 && (* ok if they're both 0 *) - (Int64.to_int yv) = 0 - | _,_ -> false - ) - | Lval(xl), Lval(yl) -> (equalLvals xl yl) - | SizeOf(xt), SizeOf(yt) -> true (*INC: xt == yt*) (* identical types *) - | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye) - | AlignOf(xt), AlignOf(yt) -> true (*INC: xt == yt*) - | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye) - | UnOp(xop,xe,xt), UnOp(yop,ye,yt) -> - xop = yop && - (equalExps xe ye) && - true (*INC: xt == yt*) - | BinOp(xop,xe1,xe2,xt), BinOp(yop,ye1,ye2,yt) -> - xop = yop && - (equalExps xe1 ye1) && - (equalExps xe2 ye2) && - true (*INC: xt == yt*) - | CastE(xt,xe), CastE(yt,ye) -> - (*INC: xt == yt &&*) - (equalExps xe ye) - | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl) - | StartOf(xl), StartOf(yl) -> (equalLvals xl yl) - - (* initializers that go through CIL multiple times sometimes lose casts they - * had the first time; so allow a different of a cast *) - | CastE(xt,xe), ye -> - (equalExps xe ye) - | xe, CastE(yt,ye) -> - (equalExps xe ye) - - | _,_ -> false -end - -and equalLvals (x: lval) (y: lval) : bool = -begin - match x,y with - | (Var(xv),xo), (Var(yv),yo) -> - (* I tried, I really did.. the problem is I see these names - * before merging collapses them, so __T123 != __T456, - * so whatever *) - (*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*) - (equalOffsets xo yo) - - | (Mem(xe),xo), (Mem(ye),yo) -> - (equalExps xe ye) && - (equalOffsets xo yo) - | _,_ -> false -end - -let equalInitOpts (x: init option) (y: init option) : bool = -begin - match x,y with - | None,None -> true - | Some(xi), Some(yi) -> (equalInits xi yi) - | _,_ -> false -end - - - (* Now we go once more through the file and we rename the globals that we - * keep. We also scan the entire body and we replace references to the - * representative types or variables. We set the referenced flags once we - * have replaced the names. *) -let oneFilePass2 (f: file) = - if debugMerge || !E.verboseFlag then - ignore (E.log "Final merging phase (%d): %s\n" - !currentFidx f.fileName); - currentDeclIdx := 0; (* Even though we don't need it anymore *) - H.clear varUsedAlready; - H.clear originalVarNames; - (* If we find inline functions that are used before being defined, and thus - * before knowing that we can throw them away, then we mark this flag so - * that we can make another pass over the file *) - let repeatPass2 = ref false in - (* Keep a pointer to the contents of the file so far *) - let savedTheFile = !theFile in - - let processOneGlobal (g: global) : unit = - (* Process a varinfo. Reuse an old one, or rename it if necessary *) - let processVarinfo (vi: varinfo) (vloc: location) : varinfo = - if vi.vreferenced then - vi (* Already done *) - else begin - (* Maybe it is static. Rename it then *) - if vi.vstorage = Static then begin - let newName, _ = A.newAlphaName vtAlpha None vi.vname !currentLoc in - (* Remember the original name *) - H.add originalVarNames newName vi.vname; - if debugMerge then ignore (E.log "renaming %s at %a to %s\n" - vi.vname d_loc vloc newName); - vi.vname <- newName; - vi.vid <- newVID (); - vi.vreferenced <- true; - vi - end else begin - (* Find the representative *) - match findReplacement true vEq !currentFidx vi.vname with - None -> vi (* This is the representative *) - | Some (vi', _) -> (* Reuse some previous one *) - vi'.vreferenced <- true; (* Mark it as done already *) - vi'.vaddrof <- vi.vaddrof || vi'.vaddrof; - vi' - end - end - in - try - match g with - | GVarDecl (vi, l) as g -> - currentLoc := l; - incr currentDeclIdx; - let vi' = processVarinfo vi l in - if vi != vi' then (* Drop this declaration *) () - else if H.mem emittedVarDecls vi'.vname then (* No need to keep it *) - () - else begin - H.add emittedVarDecls vi'.vname true; (* Remember that we emitted - * it *) - mergePushGlobals (visitCilGlobal renameVisitor g) - end - - | GVar (vi, init, l) -> - currentLoc := l; - incr currentDeclIdx; - let vi' = processVarinfo vi l in - (* We must keep this definition even if we reuse this varinfo, - * because maybe the previous one was a declaration *) - H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*) - - let emitIt:bool = (not mergeGlobals) || - try - let prevVar, prevInitOpt, prevLoc = - (H.find emittedVarDefn vi'.vname) in - (* previously defined; same initializer? *) - if (equalInitOpts prevInitOpt init.init) - || (init.init = None) then ( - (trace "mergeGlob" - (P.dprintf "dropping global var %s at %a in favor of the one at %a\n" - vi'.vname d_loc l d_loc prevLoc)); - false (* do not emit *) - ) - else if prevInitOpt = None then ( - (* We have an initializer, but the previous one didn't. - We should really convert the previous global from GVar - to GVarDecl, but that's not convenient to do here. *) - true - ) - else ( - (* Both GVars have initializers. *) - (E.s (error "global var %s at %a has different initializer than %a\n" - vi'.vname d_loc l d_loc prevLoc)); - ) - with Not_found -> ( - (* no previous definition *) - (H.add emittedVarDefn vi'.vname (vi', init.init, l)); - true (* emit it *) - ) - in - - if emitIt then - mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l))) - - | GFun (fdec, l) as g -> - currentLoc := l; - incr currentDeclIdx; - (* We apply the renaming *) - fdec.svar <- processVarinfo fdec.svar l; - (* Get the original name. *) - let origname = - try H.find originalVarNames fdec.svar.vname - with Not_found -> fdec.svar.vname - in - (* Go in there and rename everything as needed *) - let fdec' = - match visitCilGlobal renameVisitor g with - [GFun(fdec', _)] -> fdec' - | _ -> E.s (unimp "renameVisitor for GFun returned something else") - in - let g' = GFun(fdec', l) in - (* Now restore the parameter names *) - let _, args, _, _ = splitFunctionTypeVI fdec'.svar in - let oldnames, foundthem = - try H.find formalNames (!currentFidx, origname), true - with Not_found -> begin - ignore (warnOpt "Cannot find %s in formalNames" origname); - [], false - end - in - if foundthem then begin - let argl = argsToList args in - if List.length oldnames <> List.length argl then - E.s (unimp "After merging the function has more arguments"); - List.iter2 - (fun oldn a -> if oldn <> "" then a.vname <- oldn) - oldnames fdec.sformals; - (* Reflect them in the type *) - setFormals fdec fdec.sformals - end; - (** See if we can remove this inline function *) - if fdec'.svar.vinline && mergeInlines then begin - let printout = - (* Temporarily turn of printing of lines *) - let oldprintln = !lineDirectiveStyle in - lineDirectiveStyle := None; - (* Temporarily set the name to all functions in the same way *) - let newname = fdec'.svar.vname in - fdec'.svar.vname <- "@@alphaname@@"; - (* If we must do alpha conversion then temporarily set the - * names of the local variables and formals in a standard way *) - let nameId = ref 0 in - let oldNames : string list ref = ref [] in - let renameOne (v: varinfo) = - oldNames := v.vname :: !oldNames; - incr nameId; - v.vname <- "___alpha" ^ string_of_int !nameId - in - let undoRenameOne (v: varinfo) = - match !oldNames with - n :: rest -> - oldNames := rest; - v.vname <- n - | _ -> E.s (bug "undoRenameOne") - in - (* Remember the original type *) - let origType = fdec'.svar.vtype in - if mergeInlinesWithAlphaConvert then begin - (* Rename the formals *) - List.iter renameOne fdec'.sformals; - (* Reflect in the type *) - setFormals fdec' fdec'.sformals; - (* Now do the locals *) - List.iter renameOne fdec'.slocals - end; - (* Now print it *) - let res = d_global () g' in - lineDirectiveStyle := oldprintln; - fdec'.svar.vname <- newname; - if mergeInlinesWithAlphaConvert then begin - (* Do the locals in reverse order *) - List.iter undoRenameOne (List.rev fdec'.slocals); - (* Do the formals in reverse order *) - List.iter undoRenameOne (List.rev fdec'.sformals); - (* Restore the type *) - fdec'.svar.vtype <- origType; - end; - res - in - (* Make a node for this inline function using the original name. *) - let inode = - getNode vEq vSyn !currentFidx origname fdec'.svar - (Some (l, !currentDeclIdx)) - in - if debugInlines then begin - ignore (E.log "getNode %s(%d) with loc=%a. declidx=%d\n" - inode.nname inode.nfidx - d_nloc inode.nloc - !currentDeclIdx); - ignore (E.log - "Looking for previous definition of inline %s(%d)\n" - origname !currentFidx); - end; - try - let oldinode = H.find inlineBodies printout in - if debugInlines then - ignore (E.log " Matches %s(%d)\n" - oldinode.nname oldinode.nfidx); - (* There is some other inline function with the same printout. - * We should reuse this, but watch for the case when the inline - * was already used. *) - if H.mem varUsedAlready fdec'.svar.vname then begin - if mergeInlinesRepeat then begin - repeatPass2 := true - end else begin - ignore (warn "Inline function %s because it is used before it is defined" fdec'.svar.vname); - raise Not_found - end - end; - let _ = union oldinode inode in - (* Clean up the vreferenced bit in the new inline, so that we - * can rename it. Reset the name to the original one so that - * we can find the replacement name. *) - fdec'.svar.vreferenced <- false; - fdec'.svar.vname <- origname; - () (* Drop this definition *) - with Not_found -> begin - if debugInlines then ignore (E.log " Not found\n"); - H.add inlineBodies printout inode; - mergePushGlobal g' - end - end else begin - (* either the function is not inline, or we're not attempting to - * merge inlines *) - if (mergeGlobals && - not fdec'.svar.vinline && - fdec'.svar.vstorage <> Static) then - begin - (* sm: this is a non-inline, non-static function. I want to - * consider dropping it if a same-named function has already - * been put into the merged file *) - let curSum = (functionChecksum fdec') in - (*(trace "mergeGlob" (P.dprintf "I see extern function %s, sum is %d\n"*) - (* fdec'.svar.vname curSum));*) - try - let prevFun, prevLoc, prevSum = - (H.find emittedFunDefn fdec'.svar.vname) in - (* previous was found *) - if (curSum = prevSum) then - (trace "mergeGlob" - (P.dprintf "dropping duplicate def'n of func %s at %a in favor of that at %a\n" - fdec'.svar.vname d_loc l d_loc prevLoc)) - else begin - (* the checksums differ, so print a warning but keep the - * older one to avoid a link error later. I think this is - * a reasonable approximation of what ld does. *) - (ignore (warn "def'n of func %s at %a (sum %d) conflicts with the one at %a (sum %d); keeping the one at %a.\n" - fdec'.svar.vname d_loc l curSum d_loc prevLoc - prevSum d_loc prevLoc)) - end - with Not_found -> begin - (* there was no previous definition *) - (mergePushGlobal g'); - (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum)) - end - end else begin - (* not attempting to merge global functions, or it was static - * or inline *) - mergePushGlobal g' - end - end - - | GCompTag (ci, l) as g -> begin - currentLoc := l; - incr currentDeclIdx; - if ci.creferenced then - () - else begin - match findReplacement true sEq !currentFidx ci.cname with - None -> - (* A new one, we must rename it and keep the definition *) - (* Make sure this is root *) - (try - let nd = H.find sEq (!currentFidx, ci.cname) in - if nd.nrep != nd then - E.s (bug "Setting creferenced for struct %s(%d) which is not root!\n" - ci.cname !currentFidx); - with Not_found -> begin - E.s (bug "Setting creferenced for struct %s(%d) which is not in the sEq!\n" - ci.cname !currentFidx); - end); - let newname, _ = - A.newAlphaName sAlpha None ci.cname !currentLoc in - ci.cname <- newname; - ci.creferenced <- true; - ci.ckey <- H.hash (compFullName ci); - (* Now we should visit the fields as well *) - H.add emittedCompDecls ci.cname true; (* Remember that we - * emitted it *) - mergePushGlobals (visitCilGlobal renameVisitor g) - | Some (oldci, oldfidx) -> begin - (* We are not the representative. Drop this declaration - * because we'll not be using it. *) - () - end - end - end - | GEnumTag (ei, l) as g -> begin - currentLoc := l; - incr currentDeclIdx; - if ei.ereferenced then - () - else begin - match findReplacement true eEq !currentFidx ei.ename with - None -> (* We must rename it *) - let newname, _ = - A.newAlphaName eAlpha None ei.ename !currentLoc in - ei.ename <- newname; - ei.ereferenced <- true; - (* And we must rename the items to using the same name space - * as the variables *) - ei.eitems <- - List.map - (fun (n, i, loc) -> - let newname, _ = - A.newAlphaName vtAlpha None n !currentLoc in - newname, i, loc) - ei.eitems; - mergePushGlobals (visitCilGlobal renameVisitor g); - | Some (ei', _) -> (* Drop this since we are reusing it from - * before *) - () - end - end - | GCompTagDecl (ci, l) -> begin - currentLoc := l; (* This is here just to introduce an undefined - * structure. But maybe the structure was defined - * already. *) - (* Do not increment currentDeclIdx because it is not incremented in - * pass 1*) - if H.mem emittedCompDecls ci.cname then - () (* It was already declared *) - else begin - H.add emittedCompDecls ci.cname true; - (* Keep it as a declaration *) - mergePushGlobal g; - end - end - - | GEnumTagDecl (ei, l) -> - currentLoc := l; - (* Do not increment currentDeclIdx because it is not incremented in - * pass 1*) - (* Keep it as a declaration *) - mergePushGlobal g - - - | GType (ti, l) as g -> begin - currentLoc := l; - incr currentDeclIdx; - if ti.treferenced then - () - else begin - match findReplacement true tEq !currentFidx ti.tname with - None -> (* We must rename it and keep it *) - let newname, _ = - A.newAlphaName vtAlpha None ti.tname !currentLoc in - ti.tname <- newname; - ti.treferenced <- true; - mergePushGlobals (visitCilGlobal renameVisitor g); - | Some (ti', _) ->(* Drop this since we are reusing it from - * before *) - () - end - end - | g -> mergePushGlobals (visitCilGlobal renameVisitor g) - with e -> begin - let globStr:string = (P.sprint 1000 (P.dprintf - "error when merging global %a: %s" - d_global g (Printexc.to_string e))) in - ignore (E.log "%s\n" globStr); - (*"error when merging global: %s\n" (Printexc.to_string e);*) - mergePushGlobal (GText (P.sprint 80 - (P.dprintf "/* error at %t:" d_thisloc))); - mergePushGlobal g; - mergePushGlobal (GText ("*************** end of error*/")); - raise e - end - in - (* Now do the real PASS 2 *) - List.iter processOneGlobal f.globals; - (* See if we must re-visit the globals in this file because an inline that - * is being removed was used before we saw the definition and we decided to - * remove it *) - if mergeInlinesRepeat && !repeatPass2 then begin - if debugMerge || !E.verboseFlag then - ignore (E.log "Repeat final merging phase (%d): %s\n" - !currentFidx f.fileName); - (* We are going to rescan the globals we have added while processing this - * file. *) - let theseGlobals : global list ref = ref [] in - (* Scan a list of globals until we hit a given tail *) - let rec scanUntil (tail: 'a list) (l: 'a list) = - if tail == l then () - else - match l with - | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n") - | g :: rest -> - theseGlobals := g :: !theseGlobals; - scanUntil tail rest - in - (* Collect in theseGlobals all the globals from this file *) - theseGlobals := []; - scanUntil savedTheFile !theFile; - (* Now reprocess them *) - theFile := savedTheFile; - List.iter (fun g -> - theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile) - !theseGlobals; - (* Now check if we have inlines that we could not remove - H.iter (fun name _ -> - if not (H.mem inlinesRemoved name) then - ignore (warn "Could not remove inline %s. I have no idea why!\n" - name)) - inlinesToRemove *) - end - - -let merge (files: file list) (newname: string) : file = - init (); - - (* Make the first pass over the files *) - currentFidx := 0; - List.iter (fun f -> oneFilePass1 f; incr currentFidx) files; - - (* Now maybe try to force synonyms to be equal *) - if mergeSynonyms then begin - doMergeSynonyms sSyn sEq matchCompInfo; - doMergeSynonyms eSyn eEq matchEnumInfo; - doMergeSynonyms tSyn tEq matchTypeInfo; - if mergeInlines then begin - (* Copy all the nodes from the iEq to vEq as well. This is needed - * because vEq will be used for variable renaming *) - H.iter (fun k n -> H.add vEq k n) iEq; - doMergeSynonyms iSyn iEq matchInlines; - end - end; - - (* Now maybe dump the graph *) - if debugMerge then begin - dumpGraph "type" tEq; - dumpGraph "struct and union" sEq; - dumpGraph "enum" eEq; - dumpGraph "variable" vEq; - if mergeInlines then dumpGraph "inline" iEq; - end; - (* Make the second pass over the files. This is when we start rewriting the - * file *) - currentFidx := 0; - List.iter (fun f -> oneFilePass2 f; incr currentFidx) files; - - (* Now reverse the result and return the resulting file *) - let rec revonto acc = function - [] -> acc - | x :: t -> revonto (x :: acc) t - in - let res = - { fileName = newname; - globals = revonto (revonto [] !theFile) !theFileTypes; - globinit = None; - globinitcalled = false;} in - init (); (* Make the GC happy *) - (* We have made many renaming changes and sometimes we have just guessed a - * name wrong. Make sure now that the local names are unique. *) - uniqueVarNames res; - res - - - - - diff --git a/cil/src/mergecil.mli b/cil/src/mergecil.mli deleted file mode 100644 index a864c69..0000000 --- a/cil/src/mergecil.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** Set this to true to ignore the merge conflicts *) -val ignore_merge_conflicts: bool ref - -(** Merge a number of CIL files *) -val merge: Cil.file list -> string -> Cil.file diff --git a/cil/src/rmtmps.ml b/cil/src/rmtmps.ml deleted file mode 100644 index b7dea93..0000000 --- a/cil/src/rmtmps.ml +++ /dev/null @@ -1,778 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* rmtmps.ml *) -(* implementation for rmtmps.mli *) - -open Pretty -open Cil -module H = Hashtbl -module E = Errormsg -module U = Util - -(* Set on the command-line: *) -let keepUnused = ref false -let rmUnusedInlines = ref false - - -let trace = Trace.trace "rmtmps" - - - -(*********************************************************************** - * - * Clearing of "referenced" bits - * - *) - - -let clearReferencedBits file = - let considerGlobal global = - match global with - | GType (info, _) -> - trace (dprintf "clearing mark: %a\n" d_shortglobal global); - info.treferenced <- false - - | GEnumTag (info, _) - | GEnumTagDecl (info, _) -> - trace (dprintf "clearing mark: %a\n" d_shortglobal global); - info.ereferenced <- false - - | GCompTag (info, _) - | GCompTagDecl (info, _) -> - trace (dprintf "clearing mark: %a\n" d_shortglobal global); - info.creferenced <- false - - | GVar ({vname = name} as info, _, _) - | GVarDecl ({vname = name} as info, _) -> - trace (dprintf "clearing mark: %a\n" d_shortglobal global); - info.vreferenced <- false - - | GFun ({svar = info} as func, _) -> - trace (dprintf "clearing mark: %a\n" d_shortglobal global); - info.vreferenced <- false; - let clearMark local = - trace (dprintf "clearing mark: local %s\n" local.vname); - local.vreferenced <- false - in - List.iter clearMark func.slocals - - | _ -> - () - in - iterGlobals file considerGlobal - - -(*********************************************************************** - * - * Scanning and categorization of pragmas - * - *) - - -(* collections of names of things to keep *) -type collection = (string, unit) H.t -type keepers = { - typedefs : collection; - enums : collection; - structs : collection; - unions : collection; - defines : collection; - } - - -(* rapid transfer of control when we find a malformed pragma *) -exception Bad_pragma - -let ccureddeepcopystring = "ccureddeepcopy" -(* Save this length so we don't recompute it each time. *) -let ccureddeepcopystring_length = String.length ccureddeepcopystring - -(* CIL and CCured define several pragmas which prevent removal of - * various global symbols. Here we scan for those pragmas and build - * up collections of the corresponding symbols' names. - *) - -let categorizePragmas file = - - (* names of things which should be retained *) - let keepers = { - typedefs = H.create 0; - enums = H.create 0; - structs = H.create 0; - unions = H.create 0; - defines = H.create 1 - } in - - (* populate these name collections in light of each pragma *) - let considerPragma = - - let badPragma location pragma = - ignore (warnLoc location "Invalid argument to pragma %s" pragma) - in - - function - | GPragma (Attr ("cilnoremove" as directive, args), location) -> - (* a very flexible pragma: can retain typedefs, enums, - * structs, unions, or globals (functions or variables) *) - begin - let processArg arg = - try - match arg with - | AStr specifier -> - (* isolate and categorize one symbol name *) - let collection, name = - (* Two words denotes a typedef, enum, struct, or - * union, as in "type foo" or "enum bar". A - * single word denotes a global function or - * variable. *) - let whitespace = Str.regexp "[ \t]+" in - let words = Str.split whitespace specifier in - match words with - | ["type"; name] -> - keepers.typedefs, name - | ["enum"; name] -> - keepers.enums, name - | ["struct"; name] -> - keepers.structs, name - | ["union"; name] -> - keepers.unions, name - | [name] -> - keepers.defines, name - | _ -> - raise Bad_pragma - in - H.add collection name () - | _ -> - raise Bad_pragma - with Bad_pragma -> - badPragma location directive - in - List.iter processArg args - end - | GVarDecl (v, _) -> begin - (* Look for alias attributes, e.g. Linux modules *) - match filterAttributes "alias" v.vattr with - [] -> () (* ordinary prototype. *) - | [Attr("alias", [AStr othername])] -> - H.add keepers.defines othername () - | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc) - end - - (*** Begin CCured-specific checks: ***) - (* these pragmas indirectly require that we keep the function named in - -- the first arguments of boxmodelof and ccuredwrapperof, and - -- the third argument of ccureddeepcopy*. *) - | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), location) -> - begin - match attribute with - | AStr name -> - H.add keepers.defines name () - | _ -> - badPragma location directive - end - | GPragma (Attr("ccuredvararg", funcname :: (ASizeOf t) :: _), location) -> - begin - match t with - | TComp(c,_) when c.cstruct -> (* struct *) - H.add keepers.structs c.cname () - | TComp(c,_) -> (* union *) - H.add keepers.unions c.cname () - | TNamed(ti,_) -> - H.add keepers.typedefs ti.tname () - | TEnum(ei, _) -> - H.add keepers.enums ei.ename () - | _ -> - () - end - | GPragma (Attr(directive, _ :: _ :: attribute :: _), location) - when String.length directive > ccureddeepcopystring_length - && (Str.first_chars directive ccureddeepcopystring_length) - = ccureddeepcopystring -> - begin - match attribute with - | AStr name -> - H.add keepers.defines name () - | _ -> - badPragma location directive - end - (** end CCured-specific stuff **) - | _ -> - () - in - iterGlobals file considerPragma; - keepers - - - -(*********************************************************************** - * - * Function body elimination from pragmas - * - *) - - -(* When performing global slicing, any functions not explicitly marked - * as pragma roots are reduced to mere declarations. This leaves one - * with a reduced source file that still compiles to object code, but - * which contains the bodies of only explicitly retained functions. - *) - -let amputateFunctionBodies keptGlobals file = - let considerGlobal = function - | GFun ({svar = {vname = name} as info}, location) - when not (H.mem keptGlobals name) -> - trace (dprintf "slicing: reducing to prototype: function %s\n" name); - GVarDecl (info, location) - | other -> - other - in - mapGlobals file considerGlobal - - - -(*********************************************************************** - * - * Root collection from pragmas - * - *) - - -let isPragmaRoot keepers = function - | GType ({tname = name}, _) -> - H.mem keepers.typedefs name - | GEnumTag ({ename = name}, _) - | GEnumTagDecl ({ename = name}, _) -> - H.mem keepers.enums name - | GCompTag ({cname = name; cstruct = structure}, _) - | GCompTagDecl ({cname = name; cstruct = structure}, _) -> - let collection = if structure then keepers.structs else keepers.unions in - H.mem collection name - | GVar ({vname = name}, _, _) - | GVarDecl ({vname = name}, _) - | GFun ({svar = {vname = name}}, _) -> - H.mem keepers.defines name - | _ -> - false - - - -(*********************************************************************** - * - * Common root collecting utilities - * - *) - - -let traceRoot reason global = - trace (dprintf "root (%s): %a@!" reason d_shortglobal global); - true - - -let traceNonRoot reason global = - trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global); - false - - -let hasExportingAttribute funvar = - let rec isExportingAttribute = function - | Attr ("constructor", []) -> true - | Attr ("destructor", []) -> true - | _ -> false - in - List.exists isExportingAttribute funvar.vattr - - - -(*********************************************************************** - * - * Root collection from external linkage - * - *) - - -(* Exported roots are those global symbols which are visible to the - * linker and dynamic loader. For variables, this consists of - * anything that is not "static". For functions, this consists of: - * - * - functions bearing a "constructor" or "destructor" attribute - * - functions declared extern but not inline - * - functions declared neither inline nor static - * - * gcc incorrectly (according to C99) makes inline functions visible to - * the linker. So we can only remove inline functions on MSVC. - *) - -let isExportedRoot global = - let result, reason = match global with - | GVar ({vstorage = Static}, _, _) -> - false, "static variable" - | GVar _ -> - true, "non-static variable" - | GFun ({svar = v}, _) -> begin - if hasExportingAttribute v then - true, "constructor or destructor function" - else if v.vstorage = Static then - false, "static function" - else if v.vinline && v.vstorage != Extern - && (!msvcMode || !rmUnusedInlines) then - false, "inline function" - else - true, "other function" - end - | GVarDecl(v,_) when hasAttribute "alias" v.vattr -> - true, "has GCC alias attribute" - | _ -> - false, "neither function nor variable" - in - trace (dprintf "isExportedRoot %a -> %b, %s@!" - d_shortglobal global result reason); - result - - - -(*********************************************************************** - * - * Root collection for complete programs - * - *) - - -(* Exported roots are "main()" and functions bearing a "constructor" - * or "destructor" attribute. These are the only things which must be - * retained in a complete program. - *) - -let isCompleteProgramRoot global = - let result = match global with - | GFun ({svar = {vname = "main"; vstorage = vstorage}}, _) -> - vstorage <> Static - | GFun (fundec, _) - when hasExportingAttribute fundec.svar -> - true - | _ -> - false - in - trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global); - result - - -(*********************************************************************** - * - * Transitive reachability closure from roots - * - *) - - -(* This visitor recursively marks all reachable types and variables as used. *) -class markReachableVisitor - ((globalMap: (string, Cil.global) H.t), - (currentFunc: fundec option ref)) = object (self) - inherit nopCilVisitor - - method vglob = function - | GType (typeinfo, _) -> - typeinfo.treferenced <- true; - DoChildren - | GCompTag (compinfo, _) - | GCompTagDecl (compinfo, _) -> - compinfo.creferenced <- true; - DoChildren - | GEnumTag (enuminfo, _) - | GEnumTagDecl (enuminfo, _) -> - enuminfo.ereferenced <- true; - DoChildren - | GVar (varinfo, _, _) - | GVarDecl (varinfo, _) - | GFun ({svar = varinfo}, _) -> - varinfo.vreferenced <- true; - DoChildren - | _ -> - SkipChildren - - method vinst = function - Asm (_, tmpls, _, _, _, _) when !msvcMode -> - (* If we have inline assembly on MSVC, we cannot tell which locals - * are referenced. Keep thsem all *) - (match !currentFunc with - Some fd -> - List.iter (fun v -> - let vre = Str.regexp_string (Str.quote v.vname) in - if List.exists (fun tmp -> - try ignore (Str.search_forward vre tmp 0); true - with Not_found -> false) - tmpls - then - v.vreferenced <- true) fd.slocals - | _ -> assert false); - DoChildren - | _ -> DoChildren - - method vvrbl v = - if not v.vreferenced then - begin - let name = v.vname in - if v.vglob then - trace (dprintf "marking transitive use: global %s\n" name) - else - trace (dprintf "marking transitive use: local %s\n" name); - - (* If this is a global, we need to keep everything used in its - * definition and declarations. *) - if v.vglob then - begin - trace (dprintf "descending: global %s\n" name); - let descend global = - ignore (visitCilGlobal (self :> cilVisitor) global) - in - let globals = Hashtbl.find_all globalMap name in - List.iter descend globals - end - else - v.vreferenced <- true; - end; - SkipChildren - - method vexpr (e: exp) = - match e with - Const (CEnum (_, _, ei)) -> ei.ereferenced <- true; - DoChildren - | _ -> DoChildren - - method vtype typ = - let old : bool = - let visitAttrs attrs = - ignore (visitCilAttributes (self :> cilVisitor) attrs) - in - let visitType typ = - ignore (visitCilType (self :> cilVisitor) typ) - in - match typ with - | TEnum(e, attrs) -> - let old = e.ereferenced in - if not old then - begin - trace (dprintf "marking transitive use: enum %s\n" e.ename); - e.ereferenced <- true; - visitAttrs attrs; - visitAttrs e.eattr - end; - old - - | TComp(c, attrs) -> - let old = c.creferenced in - if not old then - begin - trace (dprintf "marking transitive use: compound %s\n" c.cname); - c.creferenced <- true; - - (* to recurse, we must ask explicitly *) - let recurse f = visitType f.ftype in - List.iter recurse c.cfields; - visitAttrs attrs; - visitAttrs c.cattr - end; - old - - | TNamed(ti, attrs) -> - let old = ti.treferenced in - if not old then - begin - trace (dprintf "marking transitive use: typedef %s\n" ti.tname); - ti.treferenced <- true; - - (* recurse deeper into the type referred-to by the typedef *) - (* to recurse, we must ask explicitly *) - visitType ti.ttype; - visitAttrs attrs - end; - old - - | _ -> - (* for anything else, just look inside it *) - false - in - if old then - SkipChildren - else - DoChildren -end - - -let markReachable file isRoot = - (* build a mapping from global names back to their definitions & - * declarations *) - let globalMap = Hashtbl.create 137 in - let considerGlobal global = - match global with - | GFun ({svar = info}, _) - | GVar (info, _, _) - | GVarDecl (info, _) -> - Hashtbl.add globalMap info.vname global - | _ -> - () - in - iterGlobals file considerGlobal; - - let currentFunc = ref None in - - (* mark everything reachable from the global roots *) - let visitor = new markReachableVisitor (globalMap, currentFunc) in - let visitIfRoot global = - if isRoot global then - begin - trace (dprintf "traversing root global: %a\n" d_shortglobal global); - (match global with - GFun(fd, _) -> currentFunc := Some fd - | _ -> currentFunc := None); - ignore (visitCilGlobal visitor global) - end - else - trace (dprintf "skipping non-root global: %a\n" d_shortglobal global) - in - iterGlobals file visitIfRoot - - -(********************************************************************** - * - * Marking and removing of unused labels - * - **********************************************************************) - -(* We keep only one label, preferably one that was not introduced by CIL. - * Scan a list of labels and return the data for the label that should be - * kept, and the remaining filtered list of labels *) -let labelsToKeep (ll: label list) : (string * location * bool) * label list = - let rec loop (sofar: string * location * bool) = function - [] -> sofar, [] - | l :: rest -> - let newlabel, keepl = - match l with - | Case _ | Default _ -> sofar, true - | Label (ln, lloc, isorig) -> begin - match isorig, sofar with - | false, ("", _, _) -> - (* keep this one only if we have no label so far *) - (ln, lloc, isorig), false - | false, _ -> sofar, false - | true, (_, _, false) -> - (* this is an original label; prefer it to temporary or - * missing labels *) - (ln, lloc, isorig), false - | true, _ -> sofar, false - end - in - let newlabel', rest' = loop newlabel rest in - newlabel', (if keepl then l :: rest' else rest') - in - loop ("", locUnknown, false) ll - -class markUsedLabels (labelMap: (string, unit) H.t) = object - inherit nopCilVisitor - - method vstmt (s: stmt) = - match s.skind with - Goto (dest, _) -> - let (ln, _, _), _ = labelsToKeep !dest.labels in - if ln = "" then - E.s (E.bug "rmtmps: destination of statement does not have labels"); - (* Mark it as used *) - H.replace labelMap ln (); - DoChildren - - | _ -> DoChildren - - (* No need to go into expressions or instructions *) - method vexpr _ = SkipChildren - method vinst _ = SkipChildren - method vtype _ = SkipChildren -end - -class removeUnusedLabels (labelMap: (string, unit) H.t) = object - inherit nopCilVisitor - - method vstmt (s: stmt) = - let (ln, lloc, lorig), lrest = labelsToKeep s.labels in - s.labels <- - (if ln <> "" && H.mem labelMap ln then (* We had labels *) - (Label(ln, lloc, lorig) :: lrest) - else - lrest); - DoChildren - - (* No need to go into expressions or instructions *) - method vexpr _ = SkipChildren - method vinst _ = SkipChildren - method vtype _ = SkipChildren -end - -(*********************************************************************** - * - * Removal of unused symbols - * - *) - - -(* regular expression matching names of uninteresting locals *) -let uninteresting = - let names = [ - (* Cil.makeTempVar *) - "__cil_tmp"; - - (* sm: I don't know where it comes from but these show up all over. *) - (* this doesn't seem to do what I wanted.. *) - "iter"; - - (* various macros in glibc's *) - "__result"; - "__s"; "__s1"; "__s2"; - "__s1_len"; "__s2_len"; - "__retval"; "__len"; - - (* various macros in glibc's *) - "__c"; "__res"; - - (* We remove the __malloc variables *) - ] in - - (* optional alpha renaming *) - let alpha = "\\(___[0-9]+\\)?" in - - let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in - Str.regexp pattern - - -let removeUnmarked file = - let removedLocals = ref [] in - - let filterGlobal global = - match global with - (* unused global types, variables, and functions are simply removed *) - | GType ({treferenced = false}, _) - | GCompTag ({creferenced = false}, _) - | GCompTagDecl ({creferenced = false}, _) - | GEnumTag ({ereferenced = false}, _) - | GEnumTagDecl ({ereferenced = false}, _) - | GVar ({vreferenced = false}, _, _) - | GVarDecl ({vreferenced = false}, _) - | GFun ({svar = {vreferenced = false}}, _) -> - trace (dprintf "removing global: %a\n" d_shortglobal global); - false - - (* retained functions may wish to discard some unused locals *) - | GFun (func, _) -> - let rec filterLocal local = - if not local.vreferenced then - begin - (* along the way, record the interesting locals that were removed *) - let name = local.vname in - trace (dprintf "removing local: %s\n" name); - if not (Str.string_match uninteresting name 0) then - removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals; - end; - local.vreferenced - in - func.slocals <- List.filter filterLocal func.slocals; - (* We also want to remove unused labels. We do it all here, including - * marking the used labels *) - let usedLabels:(string, unit) H.t = H.create 13 in - ignore (visitCilBlock (new markUsedLabels usedLabels) func.sbody); - (* And now we scan again and we remove them *) - ignore (visitCilBlock (new removeUnusedLabels usedLabels) func.sbody); - true - - (* all other globals are retained *) - | _ -> - trace (dprintf "keeping global: %a\n" d_shortglobal global); - true - in - file.globals <- List.filter filterGlobal file.globals; - !removedLocals - - -(*********************************************************************** - * - * Exported interface - * - *) - - -type rootsFilter = global -> bool - -let isDefaultRoot = isExportedRoot - -let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = - if !keepUnused || Trace.traceActive "disableTmpRemoval" then - Trace.trace "disableTmpRemoval" (dprintf "temp removal disabled\n") - else - begin - if !E.verboseFlag then - ignore (E.log "Removing unused temporaries\n" ); - - if Trace.traceActive "printCilTree" then - dumpFile defaultCilPrinter stdout "stdout" file; - - (* digest any pragmas that would create additional roots *) - let keepers = categorizePragmas file in - - (* if slicing, remove the bodies of non-kept functions *) - if !Cilutil.sliceGlobal then - amputateFunctionBodies keepers.defines file; - - (* build up the root set *) - let isRoot global = - isPragmaRoot keepers global || - isRoot global - in - - (* mark everything reachable from the global roots *) - clearReferencedBits file; - markReachable file isRoot; - - (* take out the trash *) - let removedLocals = removeUnmarked file in - - (* print which original source variables were removed *) - if false && removedLocals != [] then - let count = List.length removedLocals in - if count > 2000 then - ignore (E.warn "%d unused local variables removed" count) - else - ignore (E.warn "%d unused local variables removed:@!%a" - count (docList ~sep:(chr ',' ++ break) text) removedLocals) - end diff --git a/cil/src/rmtmps.mli b/cil/src/rmtmps.mli deleted file mode 100644 index e29f0c6..0000000 --- a/cil/src/rmtmps.mli +++ /dev/null @@ -1,82 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * Ben Liblit - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* rmtmps.mli *) -(* remove unused things from cil files: *) -(* - local temporaries introduced but not used *) -(* - global declarations that are not used *) -(* - types that are not used *) -(* - labels that are not used (gn) *) - - -(* Some clients may wish to augment or replace the standard strategy - * for finding the initially reachable roots. The optional - * "isRoot" argument to Rmtmps.removeUnusedTemps grants this - * flexibility. If given, it should name a function which will return - * true if a given global should be treated as a retained root. - * - * Function Rmtmps.isDefaultRoot encapsulates the default root - * collection, which consists of those global variables and functions - * which are visible to the linker and runtime loader. A client's - * root filter can use this if the goal is to augment rather than - * replace the standard logic. Function Rmtmps.isExportedRoot is an - * alternate name for this same function. - * - * Function Rmtmps.isCompleteProgramRoot is an example of an alternate - * root collection. This function assumes that it is operating on a - * complete program rather than just one object file. It treats - * "main()" as a root, as well as any function carrying the - * "constructor" or "destructor" attribute. All other globals are - * candidates for removal, regardless of their linkage. - * - * Note that certain CIL- and CCured-specific pragmas induce - * additional global roots. This functionality is always present, and - * is not subject to replacement by "filterRoots". - *) - -type rootsFilter = Cil.global -> bool -val isDefaultRoot : rootsFilter -val isExportedRoot : rootsFilter -val isCompleteProgramRoot : rootsFilter - -(* process a complete Cil file *) -val removeUnusedTemps: ?isRoot:rootsFilter -> Cil.file -> unit - - -val keepUnused: bool ref (* Set this to true to turn off this module *) -val rmUnusedInlines: bool ref (* Delete unused inline funcs in gcc mode? *) diff --git a/cil/src/testcil.ml b/cil/src/testcil.ml deleted file mode 100644 index 0c0ef01..0000000 --- a/cil/src/testcil.ml +++ /dev/null @@ -1,440 +0,0 @@ -(* - * - * Copyright (c) 2001-2002, - * George C. Necula - * Scott McPeak - * Wes Weimer - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are - * met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * - * 3. The names of the contributors may not be used to endorse or promote - * products derived from this software without specific prior written - * permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS - * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A - * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER - * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(* A test for CIL *) -open Pretty -open Cil -module E = Errormsg - -let lu = locUnknown - -(* If you have trouble try to reproduce the problem on a smaller type. Try - * limiting the maxNesting and integerKinds *) -let integerKinds = [ IChar; ISChar; IUChar; IInt; IUInt; IShort; IUShort; - ILong; IULong; ILongLong; IULongLong ] -let floatKinds = [ FFloat; FDouble ] - -let baseTypes = - (List.map (fun ik -> (1, fun _ -> TInt(ik, []))) integerKinds) - @ (List.map (fun fk -> (1, fun _ -> TFloat(fk, []))) floatKinds) - - -(* Make a random struct *) -let maxNesting = ref 3 (* Maximum number of levels for struct nesting *) -let maxFields = ref 8 (* The maximum number of fields in a struct *) -let useBitfields = ref false -let useZeroBitfields = ref true - - - -(* Collect here the globals *) -let globals: global list ref = ref [] -let addGlobal (g:global) = globals := g :: !globals -let getGlobals () = List.rev !globals - -(* Collect here the statements for main *) -let statements: stmt list ref = ref [] -let addStatement (s: stmt) = statements := s :: !statements -let getStatements () = List.rev !statements - -(* Keep here the main function *) -let main: fundec ref = ref dummyFunDec -let mainRetVal: varinfo ref = ref dummyFunDec.svar - -let assertId = ref 0 -let addAssert (b: exp) (extra: stmt list) : unit = - incr assertId; - addStatement (mkStmt (If(UnOp(LNot, b, intType), - mkBlock (extra @ - [mkStmt (Return (Some (integer !assertId), - lu))]), - mkBlock [], lu))) - -let addSetRetVal (b: exp) (extra: stmt list) : unit = - addStatement - (mkStmt (If(UnOp(LNot, b, intType), - mkBlock (extra @ - [mkStmtOneInstr (Set(var !mainRetVal, one, lu))]), - mkBlock [], lu))) - - -let printfFun: fundec = - let fdec = emptyFunction "printf" in - fdec.svar.vtype <- - TFun(intType, Some [ ("format", charPtrType, [])], true, []); - fdec - - -let memsetFun: fundec = - let fdec = emptyFunction "memset" in - fdec.svar.vtype <- - TFun(voidPtrType, Some [ ("start", voidPtrType, []); - ("v", intType, []); - ("len", uintType, [])], false, []); - fdec - -let checkOffsetFun: fundec = - let fdec = emptyFunction "checkOffset" in - fdec.svar.vtype <- - TFun(voidType, Some [ ("start", voidPtrType, []); - ("len", uintType, []); - ("expected_start", intType, []); - ("expected_width", intType, []); - ("name", charPtrType, []) ], false, []); - fdec - -let checkSizeOfFun: fundec = - let fdec = emptyFunction "checkSizeOf" in - fdec.svar.vtype <- - TFun(voidType, Some [ ("len", uintType, []); - ("expected", intType, []); - ("name", charPtrType, []) ], false, []); - fdec - - -let doPrintf format args = - mkStmtOneInstr (Call(None, Lval(var printfFun.svar), - (Const(CStr format)) :: args, lu)) - - -(* Select among the choices, each with a given weight *) -type 'a selection = int * (unit -> 'a) -let select (choices: 'a selection list) : 'a = - (* Find the total weight *) - let total = List.fold_left (fun sum (w, _) -> sum + w) 0 choices in - if total = 0 then E.s (E.bug "Total for choices = 0\n"); - (* Pick a random number *) - let thechoice = Random.int total in - (* Now get the choice *) - let rec loop thechoice = function - [] -> E.s (E.bug "Ran out of choices\n") - | (w, c) :: rest -> - if thechoice < w then c () else loop (thechoice - w) rest - in - loop thechoice choices - - -(* Generate a new name *) -let nameId = ref 0 -let newName (base: string) = - incr nameId; - base ^ (string_of_int !nameId) - - -(********** Testing of SIZEOF ***********) - -(* The current selection of types *) -let typeChoices : typ selection list ref = ref [] - -let baseTypeChoices : typ selection list ref = ref [] - - -let currentNesting = ref 0 -let mkCompType (iss: bool) = - if !currentNesting >= !maxNesting then (* Replace it with an int *) - select !baseTypeChoices - else begin - incr currentNesting; - let ci = - mkCompInfo iss (newName "comp") - (fun _ -> - let nrFields = 1 + (Random.int !maxFields) in - let rec mkFields (i: int) = - if i = nrFields then [] else begin - let ft = select !typeChoices in - let fname = "f" ^ string_of_int i in - let fname', width = - if not !useBitfields || not (isIntegralType ft) - || (Random.int 8 >= 6) then - fname, None - else begin - let tw = bitsSizeOf ft in (* Assume this works for TInt *) - let w = (if !useZeroBitfields then 0 else 1) + - Random.int (3 * tw / 4) in - (if w = 0 then "___missing_field_name" else fname), Some w - end - in - (fname', ft, width, [], lu) :: mkFields (i + 1) - end - in - mkFields 0) - [] - in - decr currentNesting; - (* Register it with the file *) - addGlobal (GCompTag(ci, lu)); - TComp(ci, []) - end - -(* Make a pointer type. They are all equal so make one to void *) -let mkPtrType () = TPtr(TVoid([]), []) - -(* Make an array type. *) -let mkArrayType () = - if !currentNesting >= !maxNesting then - select !baseTypeChoices - else begin - incr currentNesting; - let at = TArray(select !typeChoices, Some (integer (1 + (Random.int 32))), - []) in - decr currentNesting; - at - end - - -let testSizeOf () = - let doOne (i: int) = -(* ignore (E.log "doOne %d\n" i); *) - (* Make a random type *) - let t = select !typeChoices in - (* Create a global with that type *) - let g = makeGlobalVar (newName "g") t in - addGlobal (GVar(g, {init=None}, lu)); - addStatement (mkStmtOneInstr(Call(None, Lval(var memsetFun.svar), - [ mkAddrOrStartOf (var g); zero; - SizeOfE(Lval(var g))], lu))); - try -(* if i = 0 then ignore (E.log "0: %a\n" d_plaintype t); *) - let bsz = - try bitsSizeOf t (* This is what we are testing *) - with e -> begin - ignore (E.log "Exception %s caught while computing bitsSizeOf(%a)\n" - (Printexc.to_string e) d_type t); - raise (Failure "") - end - in -(* ignore (E.log "1 "); *) - if bsz mod 8 <> 0 then begin - ignore (E.log "bitsSizeOf did not return a multiple of 8\n"); - raise (Failure ""); - end; -(* ignore (E.log "2 "); *) - (* Check the offset of all fields in there *) - let rec checkOffsets (lv: lval) (lvt: typ) = - match lvt with - TComp(c, _) -> - List.iter - (fun f -> - if f.fname <> "___missing_field_name" then - checkOffsets (addOffsetLval (Field(f, NoOffset)) lv) f.ftype) - c.cfields - | TArray (bt, Some len, _) -> - let leni = - match isInteger len with - Some i64 -> Int64.to_int i64 - | None -> E.s (E.bug "Array length is not a constant") - in - let i = Random.int leni in - checkOffsets (addOffsetLval (Index(integer i, NoOffset)) lv) bt - - | _ -> (* Now a base type *) - let _, off = lv in - let start, width = bitsOffset t off in - let setLv (v: exp) = - match lvt with - TFloat (FFloat, _) -> - Set((Mem (mkCast (AddrOf lv) intPtrType), NoOffset), - v, lu) - | TFloat (FDouble, _) -> - Set((Mem (mkCast (AddrOf lv) - (TPtr(TInt(IULongLong, []), []))), NoOffset), - mkCast v (TInt(IULongLong, [])), lu) - - | (TPtr _ | TInt((IULongLong|ILongLong), _)) -> - Set(lv, mkCast v lvt, lu) - | _ -> Set(lv, v, lu) - in - let ucharPtrType = TPtr(TInt(IUChar, []), []) in - let s = - mkStmt (Instr ([ setLv mone; - Call(None, Lval(var checkOffsetFun.svar), - [ mkCast (mkAddrOrStartOf (var g)) - ucharPtrType; - SizeOfE (Lval(var g)); - integer start; - integer width; - (Const(CStr(sprint 80 - (d_lval () lv))))],lu); - setLv zero])) in - addStatement s - in - checkOffsets (var g) t; -(* ignore (E.log "3 ");*) - (* Now check the size of *) - let s = mkStmtOneInstr (Call(None, Lval(var checkSizeOfFun.svar), - [ SizeOfE (Lval (var g)); - integer (bitsSizeOf t); - mkString g.vname ], lu)) in - addStatement s; -(* ignore (E.log "10\n"); *) - with _ -> () - in - - (* Make the composite choices more likely *) - typeChoices := - [ (1, mkPtrType); - (5, mkArrayType); - (5, fun _ -> mkCompType true); - (5, fun _ -> mkCompType false); ] - @ baseTypes; - baseTypeChoices := baseTypes; - useBitfields := false; - maxFields := 4; - for i = 0 to 100 do - doOne i - done; - - (* Now test the bitfields. *) - typeChoices := [ (1, fun _ -> mkCompType true) ]; - baseTypeChoices := [(1, fun _ -> TInt(IInt, []))]; - useBitfields := true; - - for i = 0 to 100 do - doOne i - done; - - (* Now make it a bit more complicated *) - baseTypeChoices := - List.map (fun ik -> (1, fun _ -> TInt(ik, []))) - [IInt; ILong; IUInt; IULong ]; - useBitfields := true; - for i = 0 to 100 do - doOne i - done; - - (* An really complicated now *) - baseTypeChoices := baseTypes; - useBitfields := true; - for i = 0 to 100 do - doOne i - done; - - () - - -(* Now the main tester. Pass to it the name of a command "cmd" that when - * invoked will compile "testingcil.c" and run the result *) -let createFile () = - - assertId := 0; - nameId := 0; - - (* Start a new file *) - globals := []; - statements := []; - - (* Now make a main function *) - main := emptyFunction "main"; - !main.svar.vtype <- TFun(intType, None, false, []); - mainRetVal := makeGlobalVar "retval" intType; - - addGlobal (GVar(!mainRetVal, {init=None}, lu)); - addGlobal (GText("#include \"testcil.h\"\n")); - addStatement (mkStmtOneInstr(Set(var !mainRetVal, zero, lu))); - - (* Add prototype for printf *) - addGlobal (GVar(printfFun.svar, {init=None}, lu)); - addGlobal (GVar(memsetFun.svar, {init=None}, lu)); - - (* now fill in the composites and the code of main. For simplicity we add - * the statements of main in reverse order *) - - testSizeOf (); - - - (* Now add a return 0 at the end *) - addStatement (mkStmt (Return(Some (Lval(var !mainRetVal)), lu))); - - - (* Add main at the end *) - addGlobal (GFun(!main, lu)); - !main.sbody.bstmts <- getStatements (); - - (* Now build the CIL.file *) - let file = - { fileName = "testingcil.c"; - globals = getGlobals (); - globinit = None; - globinitcalled = false; - } - in - (* Print the file *) - let oc = open_out "testingcil.c" in - dumpFile defaultCilPrinter oc "testingcil.c" file; - close_out oc - - - - - -(* initialization code for the tester *) -let randomStateFile = "testcil.random" (* The name of a file where we store - * the state of the random number - * generator last time *) -let doit (command: string) = - while true do - (* Initialize the random no generator *) - begin - try - let randomFile = open_in randomStateFile in - (* The file exists so restore the Random state *) - Random.set_state (Marshal.from_channel randomFile); - ignore (E.log "!! Restoring Random state from %s\n" randomStateFile); - close_in randomFile; - (* Leave the file there until we succeed *) - with _ -> begin - (* The file does not exist *) - Random.self_init (); - (* Save the state of the generator *) - let randomFile = open_out randomStateFile in - Marshal.to_channel randomFile (Random.get_state()) [] ; - close_out randomFile; - end - end; - createFile (); - (* Now compile and run the file *) - ignore (E.log "Running %s\n" command); - let err = Sys.command command in - if err <> 0 then - E.s (E.bug "Failed to run the command: %s (errcode=%d)" command err) - else begin - ignore (E.log "Successfully ran one more round. Press CTRL-C to stop\n"); - (* Delete the file *) - Sys.remove randomStateFile - end - done - diff --git a/cil/test/small1/func.c b/cil/test/small1/func.c deleted file mode 100644 index a0f4e4e..0000000 --- a/cil/test/small1/func.c +++ /dev/null @@ -1,24 +0,0 @@ -int (*pfun1)(int (*)(int), int); -int (*pfun2)(int (*)(int), int); - -typedef int (*intfun)(int); -intfun arrfun[5]; - -int testf(int k) { - return k; -} - -int foo(int (*bar)(int), int n) { - - pfun1 = foo; - pfun1 = & foo; - pfun1 = * * * pfun2; - - pfun1 = arrfun[4]; - - pfun2(* * testf, 5); - - return 1; -} - - diff --git a/cil/test/small1/hello.c b/cil/test/small1/hello.c deleted file mode 100644 index cbe8ad0..0000000 --- a/cil/test/small1/hello.c +++ /dev/null @@ -1,8 +0,0 @@ -#include - - - -int main() { - printf("Hello world\n"); - return 0; -} diff --git a/cil/test/small1/init.c b/cil/test/small1/init.c deleted file mode 100644 index 4578b5b..0000000 --- a/cil/test/small1/init.c +++ /dev/null @@ -1,177 +0,0 @@ -#ifndef __NULLTERM -#define __NULLTERM -#define __SIZED -#endif -#include "testharness.h" - -extern int strcmp(const char*, const char*); - -/* run this with COMPATMODE=1 if compiling directly, since neither GCC nor - * MSVCC fully support the C standard */ -static char *usageplocal = "Usage"; -static char usageescape = 'C'; - -char *usagep = "Usage non-local"; -char *usagep1 = { "Usage in a brace" }; -int g = { 6 } ; - -char usages[] = "Usage string"; -char strange[] = { "several" }; - -char *null = (void*)0; - - -typedef struct s { - char *name; - int data; -} STR; - -extern int afunc(int x); -int (*fptr)(int) = afunc; - -STR a[] = { - {"first", 0}, - {"second", 1}, - {& usages[2], 2}, - { & usageescape, 3}, - { usages, 4}, -}; - - -typedef struct { - struct { - char * a1[10]; - char * a2; - char strbuff[20] __NULLTERM; - } f1; - struct { - int * i1; - } f2[5] __SIZED; -} NESTED; - -NESTED glob1; - -int glob3; -int * glob2 = & glob3; - -int afunc(int a) { - NESTED loc1; - char locbuff[30] __NULLTERM; - char indexbuff[10] __SIZED; - - loc1.f1.a2 = glob1.f1.a2; - - return * loc1.f2[3].i1 + (locbuff[0] - indexbuff[0]); -} - - - -// now initialization for union -union { - struct { - int a; - int *b; - } u1; - int c; -} uarray[] = { 1, 0, 2, 0, 3, 0 }; - - -// now some examples from the standard -int z[4][3] = -{ { 1 }, { 2 }, { 3 }, { 4 } }; - -struct str1 { int a[3]; int b;}; - -struct str1 w[] = -{ { 1 }, { 2 } }; - - -short q[4][3][2] = { - { 1 } , - { 2, 3 }, - { 4, 5, 6} -}; - -short q1[4][3][2] = { - 1, 0, 0, 0, 0, 0, - 2, 3, 0, 0, 0, 0, - 4, 5, 6, 0, 0, 0, -}; - - - -#ifdef _GNUCC -int a1[10] = { - 1, 3, 5, 7, 9, [6] = 8, 6, 4, 2}; - - -enum { member_one, member_two, member_three }; -char *nm[] = { - [member_two] = "member_two", - [member_three] = "member_three", -}; - - -#endif - - - -#define ERROR(n) { printf("Incorrect init: %d\n", n); exit(1); } -// Test the initialization -int main() { - int i; - - struct str1 astr = w[0]; - - if(strcmp(a[0].name, "first")) { - ERROR(0); - } - if(sizeof(uarray) / sizeof(uarray[0]) != 3) { - ERROR(1); - } - if(uarray[2].u1.a != 3) { - ERROR(2); - } - - if(z[2][0] != 3 || - z[2][1] != 0) { - ERROR(4); - } - - if(sizeof(w) / sizeof(w[0]) != 2 || - w[1].a[0] != 2) { - ERROR(5); - } - { - short * ps = (short*)q, * ps1 = (short*)q1; - for(i=0;i /* printf */ -#endif - -extern void exit(int); - -/* Always call E with a non-zero number */ -#define E(n) { printf("Error %d\n", n); exit(n); } -#define SUCCESS { printf("Success\n"); exit(0); } - diff --git a/cil/test/small1/vararg1.c b/cil/test/small1/vararg1.c deleted file mode 100644 index cc710a7..0000000 --- a/cil/test/small1/vararg1.c +++ /dev/null @@ -1,47 +0,0 @@ - -/* VA.C: The program below illustrates passing a variable - * number of arguments using the following macros: - * va_start va_arg va_end - * va_list va_dcl (UNIX only) - */ - -#include -#include -int average( int first, ... ); -union vararg_average { - int ints; /* We only pass ints to this one */ -}; - -#include "testharness.h" - -int main( void ) -{ - /* Call with 3 integers (-1 is used as terminator). */ - if(average( 2, 3, 4, -1 ) != 3) E(1); - if(average( 5, 7, 9, 11, 13, -1 ) != 9) E(2); - if(average( -1 ) != 0) E(3); - - SUCCESS; -} - - - -/* Returns the average of a variable list of integers. */ -int average( int first, ... ) -{ - int count = 0, sum = 0, i = first; - va_list marker; - - va_start( marker, first ); /* Initialize variable arguments. */ - while( i != -1 ) - { - sum += i; - count++; - i = va_arg( marker, int); - } - va_end( marker ); /* Reset variable arguments. */ - return( sum ? (sum / count) : 0 ); -} - -// Put this intentionally at the end -#pragma ccuredvararg("average", sizeof(union vararg_average)) diff --git a/cil/test/small1/wchar1.c b/cil/test/small1/wchar1.c deleted file mode 100644 index 3306e57..0000000 --- a/cil/test/small1/wchar1.c +++ /dev/null @@ -1,24 +0,0 @@ -#include "testharness.h" -#include - -int main() { - wchar_t *wbase = L"Hello" L", world"; - char * w = (char *)wbase; - char * s = "Hello" ", world"; - int i; - - // See if this is little or big endian - short foo = 0x0011; - char little_endian = (int) * (char*)&foo; - - for (i=0; i < 10; i++) { - if (w[i * sizeof(wchar_t)] != (little_endian ? s[i] : 0)) { - E(1); - } - if (w[i * sizeof(wchar_t) + (sizeof(wchar_t)-1)] - != (little_endian ? 0 : s[i])) { - E(2); - } - } - SUCCESS; -} diff --git a/configure b/configure index 2b53b44..d8c63fe 100755 --- a/configure +++ b/configure @@ -163,14 +163,6 @@ LIBMATH=-lm EOF fi -# Extract and configure Cil - -(cd cil && ./configure) - -# Extract 'ARCHOS' info from Cil configuration - -grep '^ARCHOS=' cil/config.log >> Makefile.config - # Summarize configuration if test "$target" = "manual"; then -- cgit v1.2.3